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l. INTRODUCTION 


A. ADA-BASED SOFTWARE TOOLS 

As the Department of Defense’s commitment to the Ada language is firm, 
there is considerable interest in the development of Ada-based, automated 
software tools. The purpose of these tools is to increase the productivity and 
efficiency of software engineering efforts. Ada-based, automated metric tools 
have been successfully implemented at the Naval Postgraduate School in 
response to this need and at the request of Naval Weapons Center, China 
Lake; specifically, Neider and Fairbank’s implementation of the Halstead 
Length Metric in a thesis entitled “AdaMeasure” [Ref. 1], and Herzig’s 
extension of “AdaMeasure” to include the Sallie Henry and Dennis Kafura 
Complexity Flow Metric [Ref. 2]. 

Rather than rely on a specific metric implementation, the design of 
“Ada Measure” incorporates a general top-down, recursive descent parser to 
collect the desired metric information. This parser relies on the premise that 
the input code has been correctly compiled before being analyzed for the 
desired metric data. This assumption allows the parser to utilize a modified 
Ada grammar which reduces the size and complexity of the parser while 
retaining the capability to parse an input file in enough detail to collect 


meaningful and relevant metric data. [Ref 1:p. 28] 


B. ANALYSIS OF REAL-TIME EMBEDDED SYSTEMS 

Of the available methods for performing software analysis, Leveson and 
Stolzy [Ref. 3] advocate the use of Petri nets as the most viable method for 
conducting a systems approach to software analysis. They argue thata 
systems approach is required since real-time embedded software seldom 
works “in a vacuum”. The choice of Petri nets as a desirable method for 
analysis is predicated on the ability of Petri nets to model hardware, software, 
and human behavior using the same language. An added advantage is that 
timing information can be incorporated into the Petri net model for analysis of 
real-time embedded systems. Leveson and Stolzy have proposed a Petri net 
based software analysis methodology that relies on deriving the untimed 
reachability graph of the system Petri net model in order to determine the 
timing constraints and properties of the final real-time imbedded system. 
Although principally concerned with software safety analysis, the analysis 
approach demonstrated by Leveson and Stolzy may be used to deduce other 
properties of a real-time embedded system. [Ref. 3] 

Shatz and Cheng [Ref. 4] were the first to describe an automated, Petri 
net based method for static analysis of Ada programs. Their analysis 
approach consisted of the following three steps / subsystems as illustrated in 
Figure 1.1: 

1. Translation of the source program into a Petri net model. 
2. Analysis of the Petri net model. 
3. Interpretation of the Petri net properties so as to derive properties of 


the source program. [Ref. 4:p. 378] 


The Front End Translator Subsystem utilized a multi-pass translation 
algorithm and a translation table that stored Petri net equivalent templates 
of Ada structures of interest. As Shatz and Cheng were specifically concerned 
with distributed programs, their translation scheme concentrated on tasks 
and their synchronization and communication mechanisms. They did not 
explicitly consider Ada packages and function program units. These Petri net 
templates of Ada structures were uniquely labeled, linked together and 


related to source code on the second pass through the source code. This 
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Figure 1.1 An Overview of the Shatz and Cheng Analysis System 


“customization” of the templates was based on the premise that each 
statement had a unique statement number. [Ref. 4:pp. 378-380] 

For the Petri Net Analysis Subsystem, Shatz and Cheng relied upon the 
P-NUT suite of tools provided by Rami R. Razouk of the University of 
California, Irvine. [Ref. 4:p.379] 

The Back End Interpreter / Display Subsystem provided a metric report 
that related the results of the Petri net static analysis in the context of the 
source program so as to be an understandable and useful aid to the Ada 
programmer. [Ref. 4:p.378] 

The software analysis methodology proposed by Leveson and Stolzy 
requires prior knowledge of the properties the programmer wants to analyze, 
e. g., what constitutes a fault, failure, deadlock, etc. [Ref. 3:p. 1]. The 
incorporation of this preliminary analysis information into an automated 
software analysis tool suggests a capability to interactively query the Back 
End Interpreter/ Display Subsystem rather than receive a canned metric 
product. These queries must be based upon knowledge, from either the 
programmer or the Interpreter Subsystem, of the source code to Petri net place 
mapping. 

Although principally concerned with a distributed software system’s 
potential communication patterns and complexity metrics [Ref 4.:p. 377; 

Ref. 5], Shatz and Cheng’s concept of an automated petri net translator is 
ideally suited to the area of interactive software analysis. Unfortunately, the 
exclusion of key Ada constructs, the template implementation of the Front 


End Translator Subsystem, and the non-interactive Back End Interpreter / 


Display Subsystem limits the usefulness of Shatz and Cheng’s Analysis 


System as a practical interactive software analysis tool. 


C. OBJECTIVES 

It is the objective of this thesis to demonstrate and implement an 
algorithm for the automated translation of Ada source code to a Petri net 
model. This algorithm has an advantage over the template algorithm in that 
it requires only one pass through the source code. In addition, the 
intermediate products produced by this algorithm can facilitate the storing of 
libraries of source code Petri net models. This implementation of an 
automated Ada source code translator utilizes the same parsing technology of 
metrics developed at the request of Naval Weapons Center, China Lake and is 
intended to be the preliminary work for a new automated software analysis 
tool entitled “AdaFlow”. Although “AdaFlow” is not intended to produce a 
metric product, it is designed to demonstrate the versatility of the 
“AdaMeasure” technology and to be the logical companion of the 


“AdaMeasure” metric product. 


Il. REVIEW OF THEORY 


A. PETRINETS 
Petri nets were originally designed asa tool to model communication 
between asynchronous components of a computer system by Car! Petri [Ref. 
6]. Petri nets have evolved as a modeling tool and have found application in 
such diverse areas of study as software, hardware, economics, and chemistry. 
A formal definition of a Petri net is a five-tuple, ® = (P, T, J, O, po), 


where: 


_—_ 


P = {p}, p2,°*-, Pn} is a finite set of places and n 2 0. 

2. T = {t}, ta,, tm}isa finite set of transitions; m 2 0; and the set of 
places and transitions are disjoint, PQ T = ©. 

3. Jisthe input function T > P”’, a mapping from transitions to bags of 
places. 

4. Oisthe output function T > P”, a mapping from transitions to bags of 
places. 

5. pois the initial marking for the net, P => N where N is the set of 
nonnegative integers. [Ref. 3:pp. 396-397] 

A graph structure is most often used to illustrate a Petri net. Standard 
symbols include a circle “O” to represent a place and a bar “|” to represent a 
transition. An arrow or arc from a place to a transition defines the place as an 
input to the transition while an arc from a transition to a place defines the 


place as an output to the transition as illustrated in Figure 2.1. [Ref 3:p. 387] 


In order to illustrate the dynamic nature of a system being modeled, Petri 
nets utilize tokens. The initial marking, po, deposits zero or more tokens in 
each Petri net place. This marking corresponds to the initial state of the 


system. The net is animated by the movement of tokens from input places, 


Input Place Marked Place 
Are (+) 


Transition 
Are 


Output Place 


Enabled Transitions 


Ff ellesaa 


Figure 2.1 Standard Petri Net Symbology 


through a transition, to output places. In order for a token to move, the 
transition separating source places and destination places must be enabled. A 
transition is enabled only if each input place to the transition contains at least 
as many tokens as there are arcs from the input place to the transition . 


Examples of enabled transitions are shown in Figure 2.1. In an untimed Petri 


net, a transition may fire any time after it is enabled. When a transition fires, 
all tokens enabling that transition are removed from their corresponding 
input places and one token is deposited in each of the transition’s output 
places. Transitions continue to fire as long as at least one transition remains 
enabled. [Ref. 3] 

The initial state of the system is defined by the initial marking, po. When 
a transition fires, the new marking of tokens defines a new system state. For 
an untimed Petri net, the enabled transitions may fire in any order. The set of 
all possible states that may exist based on all possible orderings of transition 
firings defines the reachable states for the system. In this thesis, a 
reachability graph will be used to illustrate the reachable states for a system. 

A Time Petri net is a Petri net that is enhanced to include timing 
constraints on the firing of transitions. The addition of timing information 
may limit the reachable states of the system, but may never increase them. 
This principle is key to the analysis technique described by Leveson and 
Stolzy that begins with the untimed reachability states of a system and works 


backward to the real-time properties of a system. [Ref. 3:p. 389] 


B. MODELING COMPUTER SOFTWARE 

In his description of modeling with Petri Nets, Peterson claims that the 
modeling of computer software is “...perhaps the most common use of Petri 
nets and has the greatest potential for useful results.” [Ref. 7:p. 54] 

In modeling, a decision must be made concerning which aspects of the real 


system are to be incorperated into the model. When applied to computer 


software, Petri net models best illustrate the aspect of software control 


structures. Peterson’s rationale for modeling control structures is as follows: 


Petri nets are meant to model the sequencing of instructions and the flow of 
information and computation but not the actual information values 
themselves. A model of a system, by its nature, is an abstraction of the 
modeled system. As such it ignores the specific details as much as possible. 
If all the details were modeled, then the model would be a duplicate of the 
modeled system, not an abstraction. [Ref. 7:p. 55] 


As flowcharts are a standard means of representing the control structures 
of a program, Peterson utilizes flowcharts as an intermediate form of the 
source code in the translation of concurrent computer software. In his 
description of the translation methodology, single processes in a system of 
concurrent processes are first described in terms of flowcharts. These 
flowcharts are translated to Petri nets, and then combined to yield one Petri 
net representation for a system of concurrent processes. [Ref. 7:pp. 54-68] 

The translation of flowcharts to Petri nets relies on the similarities 
between these two graphical means of representating of a program. Ina 
flowchart, nodes model actions or events, while arcs between nodes model 
conditions. In a Petri net, the transitions model actions, while nodes model 
conditions. Peterson’s translation is, therefore, very straightfoward: replace 
the nodes of the flowchart with transitions in the Petri net and the arcs of the 
flowchart with places in the Petri net as illustrated in Figure 2.2. Peterson 
describes a one-to-one correspondence between flowchart arcs and Petri net 
places, while flowchart nodes are represented in different ways, depending on 
the type of the node: computation or decision [Ref. 7: p. 58]. The combining of 
Petri net models for single processes into one model representing a system of 
concurrent processes is accomplished by introducing the concept of 


parallelism and synchronization. 





Computation 


& Computation 


r 


Figure 2.2 Translating Flowcharts to Petri Nets [Ref 7:p. 57] 


Peterson describes three ways parallelism can be introduced into a 
software model: 

1. Simply take the union of all Petri nets to represent the concurrent 
execution of each individual process. Each process has an initial 
marking in the place representing the initial program counter for that 
process. 

2. Utilize the FORK and JOIN operations originally proposed by Dennis 
and Van Horn [Ref. 8]. The FORK and JOIN operations are illustrated 
in Figure 2.3. 

3. Utilize the parbegin and parend control structures suggested by 


Dijkstra [Ref. 9]. This construct is illustrated in Figure 2.4. 
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Figure 2.3 Modeling the FORK and JOIN Operations [Ref 7:p. 60] 


Parbegin 


s : 


Parend 


O) 


Figure 2.4 Modeling the Parbegin and Parend Operations [Ref 7:p. 61] 


In his assessment of the first method, Peterson remarks that although it 
introduces a parallelism that cannot be represented in a flowchart, it is still 
not a very useful method of modeling parallelism [Ref. 7:p. 59]. The second 
method is a more accurate depiction of how parallelism would normally be 
introduced into a process in a computer system; however, it limits the number 
of processes that may be spawned to two. The parbegin and parend structure 
offers the accurate depiction of how parallelism would normally be introduced 
without the restriction on the number of processes that may be spawned [Ref. 
T:pp. 59-61] 

The concept of synchronization entails the sharing of information and 
resources between individual processes. This communication between 
processes must be restricted and coordinated in order to ensure correct 
operation of the overall system. Peterson describes classic synchronization 
problems such as the mutual exclusion problem [Ref. 10], the producer / 
consumer problem [Ref. 9], the dining philosophers problem [Ref. 9], and the 
readers/ writers problem [Ref. 11], and presents some Petri net solutions to 
these problems. As these classic synchronization problems do not reflect the 
synchronization problems of a specific computer language, Peterson does not 
relate his solutions to a computer software translation algorithm. His 
solutions merely illustrate general methods for modeling general classes of 
synchronization problems. A discussion of Ada’s synchronization mechanisms 
and a specific translation algorithm will be presented in Chapter III. [Ref. 7: 
pp. 61-69] 

The procedure for modeling computer software outlined by Peterson relies 


on two translations: from source code to flowchart and from flowchart to Petri 
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net. In addition, one must then add Petri net details in order to model 
parallelism and synchronization mechanisms between the Petri nets produced 
from the two translations. Although this procedure will ultimately yield a 
Petri net model of the computer software under study, it is not a procedure 
that is readily automated. The modeling algorithm detailed by Shatz and 
Cheng, although specific to Ada software, overcomes this limitation by 
automating the translation process. This modeling algorithm required two 
steps: 

1. Preprocessing of the source code which collects “necessary information” 

into some tables for later reference. 

2. Translation of the source code. [Ref. 4] 

The preprocessing step required one complete pass through the source 
code to build the tables required by the translator. As one example of what is 
considered “necessary information” for the preprocessor to collect, Shatz and 
Cheng describe the maintenance of an Entry Call Table. The Entry Call 
Table has four fields: 


paed 


The name of the calling task. 
2. The name of the called task. 

3. The name of the entry in the called task. 

4. A unique identifier for the entry call. 
In order to uniquely identify entry calls and others information collected by 
the preprocessor, Shatz and Cheng assume each statement has a unique 
statement number. [Ref 4:p. 380] 
The translation phase of the algorithm required a second complete pass 


through the source code. The translator utilized a template table of stored 
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Petri net equivalent models of Ada control structures. These Petri net 
equivalent models and the resulting source program model were stored and 
described in terms of a Petri net abstract grammar. As defined by Shatz and 
Cheng, a Petri net abstract grammar is a triple AG = (P, T, PR), where: 
1. Pisa finite set of non-terminal symbols that correspond to places in the 
Petri net. 
2. Tisa finite set of terminal symbols that correspond to transitions in the 
Petri net. 
3. PRisa finite set of production rules of the form u => tv, where u and v 
are strings of symbols from P, and t is a symbol from T. 
An initial string is used to represent the initial marking of the Petri Net. 
Figure 2.5 illustrates an example Petri net model and the corresponding 
abstract grammar representation. [Ref. 4:pp.378-379] 

The process of translating Ada constructs consisted of retrieving the 
appropriate Ada construct model from the template table, customizing the 
templates, and linking the templates together. Customizing the templates 
not only uniquely identifies places within the templates, it also provides the 
means to automate the modeling of synchronization mechanisms between 
Petri net models of single processes. Consider the example of Figure 2.6. 
Shatz and Cheng’s templates for Ada’s entry statement and accept statement 
are shown before customization. Customization results in the Ack-entry place 
for both templates receiving the same unique identifier. Therefore, in the 
abstract grammar representation, these two building blocks of Ada’s 


synchronization mechanism are effectively linked. [Ref. 4:p. 380] 
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Figure 2.5 An Abstract Grammar Representation 
of a Petri Net Model [Ref. 4:p. 384] 





Figure 2.6 Modeling Ada’s Synchronization Mechanism 
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This algorithm for modeling computer software is superior to Peterson’s 


algorithm. Although automated, there exist some notable shortcomings that 


prevent the use of this template algorithm in a general, automated, Ada 


software analysis tool. These shortcomings include: 


i 


The algorithm requires multiple passes through the source code. The 
first pass is utilized to determine the underlying structure of the 
program, while the second pass effects the actual translation. 

The tables assembled in the first pass do not include scoping 
information and ,therefore, do not present a true picture of the 
program’s underlying structure. In a general Ada program, with and 
use clauses can dramatically alter the context of compilation and 
provide direct visability to identifiers without using the “dot” or 
component select notation. If the tables are unable to provide scoping 
information, the constuct being modeled may be misidentified. 

The method used to depict parallelism is to provide an initial marking 
for the main procedure and each task in the source code. This is not an 
accurate description of of how parellelism would normally be 
introduced into a process. A more accurate depiction would utilize the 
parbegin and parend structures. 

The assumption of unique statement numbers is, perhaps, unrealistic. 
If by “statement number”, one refers to the line of text in the source 
code where the statement is physically located, then the translation 
algorithm imposes restrictions on the language beyond those of the 


Language Reference Manual (LRM) [Ref. 12]. 
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5. The use of templates is a rigid method that does not accurately depict 


the flow of control in a general Ada program. 


C. FRONT-END MACHINE 

Rather than rely on a tool that was only capable of gathering specific 
metric information, Neider and Fairbanks chose to develop a generic Ada 
front-end machine consisting of a lexical analyzer and parser. This front-end 
machine was used to construct an intermediate representation of the source 
program, or derivation tree, which is utilized to collect the information 
necessary to implement the desired metric. [Ref. 1:p. 18] 

As this derivation tree determined the underlying structure of the 
program incrementally, while the program was being scanned, the desired 
metric information could be collected in one pass through the source code. 
This is accomplished by effecting emissions of the desired information from 
the front-end machine at appropriate places in the derivation tree. By 
altering these emissions from metric information to Petri net information, the 
front-end machine can be utilized to translate Ada source code to Petri net 
models. 

1. The Modified Ada Grammar 

Nieder and Fairbanks decided on a top-down, recursive-descent 
parsing algorithm as the implementation of the parser. Recursive-descent 
parsers are closely related to the LL(1) subset of the context-free grammars 
and are among the most popular of the compiler parsers [Ref. 13:p. 167]. For 
this reason, it was necessary to “massage” the Backus-Naur description of the 


Ada langue [Ref. 12: Appendix E], a non-LL(1) grammar, into an LL(1)-like 
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grammar capable of being parsed deterministically. In the context of this 
thesis, “massage” refers to the process of removing instances of left recursion 
and then left factoring the grammar so the parser can choose the correct 
production rule based on one token look-ahead. [Ref. 1:p. 13] 

Nieder and Fairbanks discovered several instances of left-recursion 
in the Ada grammar. The following excerpt from their thesis illustrates Ada’s 
left-recursive quality for the production rule NAME. Ada’s terminal tokens 
will appear in lower case letters while nonterminals will appear in upper case 


letters: 


The production rules, when taken directly from the LRM, appear as follows: 
NAME identifier 
character__literal 
string _ literal 
INDEX__COMPONENT 
SLICE 
SELECTED_COMPONENT 
ATTRIBUTE 


WVUUUUUY 


INDEXED_COMPONENT = PREFIX (EXPRESSION ) 
SLICE == PREFIX (DISCRETE_ RANGE) 
SELECTED__COMPONENT => PREFIX .SELECTOR 
ATTRIBUTE = PREFIX? ATTRIBUTE__DESIGNATOR 


PREFIX => NAME 
= FUNCTION_CALL 


When starting with NAME and substituting in the productions, the left 
recursion becomes readily apparent. For example: 


NAME => SLICE > PREFIX(DISCRETE_ RANGE) > NAME(DISCRETE__RANGE). 
{Ref. l:pp. 14 15] 


These instances of left recursion required extensive massaging in order to 


yield an LL(1) grammar. The resulting grammar is included as Appendix A. 
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2. Lexical Analysis 


The task of assembling a sequence of source characters into the 
terminal alphabet or tokens of the language is within the province of the 
scanner or lexical analyzer [Ref. 13:p. 18]. There are seven classes of tokens 
that comprise the terminals of the Ada language. These token classes are 
known as identifiers, separators, numeric literals, delimiters, comments, 
character literals, and string literals. In addition, the Ada language recognizes 
a special sub-class of identifier known as reserved words. 

The process of lexical analysis entails reading the source program one 
character at a time and building the tokens deterministically, with one 
character look-ahead, based upon the definition of Ada’s lexical elements as 
described in Chapter Two of the LRM [Ref. 12]. 

Neider and Fairbanks described seven deterministic finite state machines 
capable of recognizing the seven basic token classes of the Ada language. 
These machines will be discussed in greater detail in Chapter II. (Ref. 1:pp. 
18-25]. 

3. Recursive-Descent Parser 

The implementation of Neider and Fairbanks’ recursive-descent 
parser consists of a set of function calls with a one-to-one correspondence to 
the non-terminals of the Modified Ada Grammar. These function calls return 
either a true or false value. A return of false excludes the non-terminal from 
the derivation tree while a return of true indicates that the non-terminal is 
part of the derivation tree. As non-terminals may contain tokens as part of the 
production string, the parser can query the lexical analyzer if the current 


token matches a terminal in the production string. If a match is found, the 
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token becomes a leaf of the derivation tree and a new token is assembled by 
the lexical analyzer. Parsing begins with a call to the function 


COMPILATION, the starting non-terminal of the grammar [Ref. 1]. 
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Ill. THE METAMORPHOSIS OF “ADAMEASURK” 


“AdaMeasure” is an evolving metric tool that is utilized and maintained 
by the Software Missile Branch of the Naval Weapons Center, China Lake. 
Since it was first published in March of 1987, The “AdaMeasure” front-end 
machine has undergone a significant change in appearance while retaining 
it’s basic functionality. During the course of this thesis, several changes to the 
lexical analyzer and the Modified Ada Grammar were proposed and 
incorporated. Changes to the lexical analyzer were made primarily in the 
interest of speed and readability, while changes to the Modified Ada Grammar 
were made primarily in the interest of regularity. The first two sections of 
this chapter outline these general modifications, while the last section details 
the changes made in the Parser (Appendix C) emissions in order to realize a 


Petri net mode! of the source code. 


A. LEXICAL ANALYZER 

Prior to this thesis, many of the functional tasks of lexical analysis were 
interspersed throughout the different packages that comprised the front-end 
machine. This thesis sought to group all the functional tasks of lexical 
analysis into one package with an interface that hides the implementation 
details as much as possible. The result of this effort is the Token Scanner 
package.(Appendix H). This package presents an interface that, to the user, 
makes the source file appear as a logical file of Ada tokens. A finite set of 


operations are provided to the user that include the ability to view the token 


an 


under the read head, view the token that will come under the read head next, 
and the ability to advance the read head one token at a time. In addition, the 
capabilities of the Token Scanner were expanded to include the capability to 
distinguish reserved words from identifiers. This change allowed an efficient 
hash search for reserved words that was hidden from the user, and resulted in 
a significant increase in speed for the front-end machine. 

The implementation of the Token Scanner utilizes a pipe to assemble the 
tokens of the language and a filter to prevent comments and separators from 
ever coming under the read head or into the look-ahead position. The seven 
deterministic finite machines described by Nieder and Fairbanks [Ref. 1] are 
utilized in the pipe to identify the tokens as they are assembled. These ~ 
machines have been enhanced to conform more closely to the exact lexical 
requirements of the LRM. The only lexical requirement the Token Scanner 
does not enforce, is the requirement that each extended digit of a based 
numeric literal be less than the base [Ref. 12:p. 2-5]. These enhancements 
have virtually eliminated the Token Scanner’s reliance on the precondition 


that the source code be correctly compiled prior to being analyzed. 


B. GRAMMAR 
As this thesis progressed, it became apparent that there were many 
productions in the Modified Ada Grammar that could be simplified. Consider 
the original productions that were designed to parse an Ada function: 
FUNCTION _UNIT= DESIGNATOR FUNCTION __UNIT__ TAIL 


FUNCTION. UNIT_TAIL = isnew NAME|IGENERIC_ACTUAL__PART ?]; 
=> | FORMAL__PART ?] return NAME FUNCTION _ BODY 


ae 


FUNCTION _ BODY => is[FUNCTION_ BODY_ TAIL ?] 


— 8 
FUNCTION _BODY_TAIL = separate; 
=> <>; 
=> SUBPROGRAM_BODY 
=> NAME; 


These productions were simplified to the following production rule: 


FUNCTION_UNIT=S DESIGNATOR|[FORMAL_PART ?] return NAME is 
SUBPROGRAM_BODY 
=> DESIGNATOR [FORMAL __PART ?] return NAME; 
=> DESIGNATOR [FORMAL_ PART ?] return NAME renames 
NAME; 
=> DESIGNATOR is SUBPROGRAM __BODY 


Another significant change in the grammar concerned the production rules for 
SUBPROGRAM __BODY. There were numerous instances of productions 


requiring the sequence: 


{[DECLARATIVE_ PART ?] begin SEQUENCE__OF__STATEMENTS [exception 
[EXCEPTION _ITANDLER]* ?] end [DESIGNATOR 7] ; 


Rather than duplicate this sequence for each production, the productions 
requiring this sequence were modified to utilize the SUBPROGRAM__BODY 
production rules. This simplification relies on the precondition of correctly 
written code verified by a compiler prior to being analyzed. The Modified Ada 
Grammar listed in Appendix A contains all the changes to the original 
grammar and is the current grammar utilized in both “AdaMeasure” and 


“AdaFlow”. 


C. PARSER EMISSIONS 
1. Code Blocks 
A key issue in any source code to Petri net translation algorithm is 
the method used for transforming source code space into Petri net space. 


Shatz and Cheng [Ref. 4] chose to use “statement numbers” that corresponded 
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to the line of text in the source code where the statement was physically 
located. This method of transformation assumes that each Ada control 
structure has a unique statement or line number. This assumption is 
unrealistic as it imposes restrictions on the language beyond those of the 
LRM. 

One method of transforming source code space to Petri net space is 
suggested by the very aspect of computer software Petri nets model best: 
control structures. Software control structures not only correspond to 
transitions in a Petri net, they also serve to separate source code into “blocks” 
of code that correspond to unique Petri net places. It is not sufficient, 
however, to rely on control structures as the only demarcation of where these 
code blocks begin and end. One must also consider the possible source code 
destinations that a control structure can transition to when executed. These 
possible destinations include labels, procedures, functions, and task entries. In 
general, a control structure is located in the current code block and denotes 
the end of that code block, while a destination denotes the end of the current 
code block and is located in the next code block. The execution of control 
structures is simply the order in which these code blocks are interconnected. 

Consider the simple Ada program and corresponding Petri net places 
of Figure 3.1. The procedure entitled MAIN defines a destination ofa 
procedure call statement and, therefore, begins a new code block. A procedure 
is a scope defining construct that, when viewed from the perspective of the 
invoker, can be considered as one large code block or a super-place in the 
corresponding Petri net. The details of control flow internal to the procedure 


are not visible to the outside world. All the declarations that follow MAIN are 
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procedure MAIN is procedure MAIN 
type GRADE_ BOOK is array (positive range 1..10) of 


natural; 
INDEX: natural; 
TOTAL: natural ; 
AVERAGE: natural; 
STUDENT: GRADE _ BOOK; 
begin 
INDEX := 0; 
TOTAL:= 0; 
<<ADD_AGAIN> > 
INDEX := INDEX + I; <<ADD_AGAIN > > 
TOTAL:= TOTAL + 
STUDENTUNDEX); 
if INDEX = 10) then 
goto CONTINUE; 
else 
goto ADD_ AGAIN; 
end if; 
<<CONTINUE> > 
AVERAGE := TOTAL / 10; 
end MAIN; 


<<CONTINUE> > 


end MAIN 





Figure 3.1 Transforming Source Code Blocks to Petri Net Places 


within the same code block as MAIN. The reserved word begin labels the start 
of MAIN’s internal control structure and starts a new code block. The label 
ADD_AGAIN ends the first internal code block and is located in the next 
code block. The ifstatement labels the root location of a multi-way decision 
path and, therefore, is the beginning of a new code block. The first path of the 


ifstatement is an unconditional jump to the label CONTINUE. This 


25 


statement is part of, and denotes the end of, the if code block. The else clause 
of the ifstatement reactivates the root location as the current code block. The 
goto statement of the second path has the same effect on the if code block as 
the goto of the first path. The end if statement is a possible destination for any 
of the paths of the if statement and, as such, denotes the end of the code block 
in the current path if it has not already ended. The end ifstatement begins, 
and is located in, a new code block. The CONTINUE label ends the end if code 
block and is located in the next code block. The end of procedure MAIN labels 
a possible destination for control statements such as return; therefore, it 
denotes the end of the current code block and is the first statement in the next 
code block. Upon completing the parse of MAIN’s subprogram body we exit 
the last internal code block and the enclosing procedure code block. 

A necessary condition for translation is that for every code block in 
the source program, there must exist a unique Petri net place. This property 
is not commutative as pseudo-places exist in Petri nets that have no 
corresponding code blocks in the source program. These pseudo-places will be 
discussed when we consider the Parser’s emissions for Petri nets. 

Due to the front-end machine’s ability to determine the deep, 
underlying structure of Ada programs, it is possible to determine when a code 
block, and the related Petri net place, begins and ends on the basis of where 
we are in the grammar rather than where we are in a text file. Based on this 
determination, the Parser emits information to the Code Blocker (Appendix 
I), 

The Code Blocker is responsible for assigning a unique Petri net place 


number to each code block that is entered by the Parser. In addition, the code 
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blocker accepts and stores information from the Parser that relates the Petri 
net places to their locations in the text file. Although not currently used by 
the system, this information is maintained for two reasons: 

1. Itiseasier for the user to relate Petri net places to source code locations 
rather than grammar locations. 

2. Itis anticipated that, at a later date, an interactive, high level user 
interface will be incorporated that will require this mapping 
information. 

2. Symbol Table 

Simply stated, the function of a symbol table is to store and retrieve 
identifiers and their associated properties. There are two properties of 
interest for a source code to Petri net translator: an identifier’s attribute and 
location. 

An identifier’s attribute or classification is used to determine 
whether the identifier is a control structure or a possible destination of 
executing a control structure. Ifa control structure, the attribute uniquely 
classifies the type of control structure that will later be modeled. The 
attribute also determines whether or not the identifier is the beginning ofa 
new scope. 

As Ada isa statically scoped language with strict visibility rules, any 
symbol! table used with Ada must preserve this scoping information. In 
addition, an Ada symbol table must allow for the capability to provide 
visibility of identifiers in previously exited scopes. This requirement is a by- 


product of Ada’s package facility. 
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Symbol table location information, as it applies to a Petri net 
translator, relates the identifier to a unique code block and, therefore, a 
unique Petri net place. As an identifier may be declared before the location or 
code block is known, the capability to update an identifier’s location must be 
supported by the symbol table. 

By utilizing the location information from the Code Blocker, the 
front-end machine has all the additional resources required to manage the 
Symbol Table (Appendix E). Returning to the example of Figure 3.1, and 
ignoring the Parser’s management of the Code Blocker for entering, exiting, 
and reactivating code blocks, the Parser’s management of the Symbol Table 
can be illustrated. 

When the Parser encounters the identifier MAIN, it obtains the 
current code block number from the Code Blocker, say “1”, and inserts the 
identifier into the Symbol! Table with a procedure declaration attribute and a 
location of “1”. Asa procedure declaration is a scope defining construct, this 
action causes the Symbol Table to enter a new scope. 

The sequence of statements within a procedure body may contain a 
return statement. A return statement is used to complete the execution of the 
innermost enclosing procedure and may be thought of as an unconditional 
transfer to the end of the procedure. For this reason, the Parser makes an 
entry in the symbol table for the last code block in the procedure with a label 
attribute and a location of “0” or undefined. As each label in Ada must havea 
unique identifier, the reserved word end is used as the identifier for the last 
code block in MAIN. This method of labeling destination code blocks that do 


not have a user defined label ensures uniqueness and avoids clashes with user 
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defined labels as programmers are restricted from using a reserved word as a 
label identifier. 

The next identifier that results in a Symbol Table entry is the label 
ADD_ AGAIN. The Parser inserts ADD__AGAIN with a label attribute and 
the code block location, now “3”. 

Upon parsing the if statement, the Parser inserts the identifier zfin 
the Symbol Table with a special attribute that identifies the if control 
structure and the location “4”. This attribute causes the Symbol Table to 
enter a new scope. The Parser then inserts the :fstatement’s corresponding, 
undefined end label. 

The goto statement of the first if statement path causes the Parser to 
search the Symbol Table for the identifier CONTINUE. When the Symbol 
Table informs the Parser that CONTINUE is not declared, the Parser 
assumes that the goto statement is an implicit declaration of the label 
CONTINUE. This causes the Parser to insert a label for CONTINUE with an 
undefined code block location in the Symbol Table. The goto statement of the 
second if statement path causes the Parser to search the Symbol Table for the 
identifier ADD AGAIN. The Symbol Table finds the label and reports this 
fact to the Parser. The Parser then checks to see if the location is defined (non- 
zero). If not defined, the Parser would update the Symbol Table entry to the 
current code block number. 

The end if statement results in the Parser ordering the Symbol Table 
to search for the end label. When the Symbol Table finds the end label, the 
Parser then updates the label’s location to the correct code block number of “5” 


and orders the Symbol! Table to exit the scope. 


Ze 


When the CONTINUE label is encountered, the Parser orders the 
Symbol Table to search for the identifier CONTINUE. The Symbol Table 
finds the label and reports this fact to the Parser. The Parser then updates the 
label’s location to the current code block number of “6”. 

The end MAIN statement results in the Parser ordering the Symbol 
Table to search for the end label. When the Symbol Table finds the end label, 
the Parser then updates the label’s location to the correct code block number of 
“7” and orders the Symbol Table to exit the scope. Figure 3.2 illustrates the 


scoped symbol table at the end of the parse. 


KEY MAIN 





ATIRIBUTE PROCEDURE DECLARATION SCOPE 1 
LOCATION 1 





KEY: END 
ATTRIBUTE: LABEL 


KEY: ADD_ AGAIN KEY. IF 









ATTRIBUTE: LABEL >| ATTRIBUTE. IF STATMENT 





SCOPE 2 








LOCATION 7 LOCATION: 3 LOCATION: 4 









KEY: END KEY: CONTINUE 
ATTRIBUTE. LABEL 


LOCATION: 6 







SCOPE 3 ATTRIBUTE LABEL 


LOCATION 5 





Figure 3.2 Storing Source Code Blocks in a Symbol Table 


Ada supports the capability for a programmer to declare and invoke 
procedures, function, packages, tasks and entries before their corresponding 
bodies have been parsed. This capability is akin to the Pascal forward 
declaration. In order to handle these forward declarations, the Parser inserts 


the identifier, the appropriate declaration attribute, and an unknown 


30 


location. The Parser then inserts the corresponding end label with an 
unknown location and exits the scope. When the declaration’s corresponding 
body is parsed, the Parser inserts the same identifier, with the appropriate 
body attribute, and the known code block location. This causes the Symbol 
Table to automatically search for and update the environment of definition, 
and enter that environment’s scope. 
3. Petri Net Transitions 

Petri net transitions model the execution of control structures and 
connect Petri net places. Petri net places can be the source or destination ofa 
transition For the purpose of this thesis, Petri net places will be divided into 
three categories: known Petri net places, unknown Petri net places, and 
pseudo-places. Known Petri net places correspond to the code block that is 
currently being parsed, while unknown Petri net places correspond to either a 
code block declared in the symbol table, or the next code block to be 
encountered. In all cases, known and unknown Petri net places correspond to 
a unique code block in the source. Pseudo-places are Petri net places that are 
required to model a control structure but have no corresponding location in 
source code. As an example of all three places, consider Figure 3.3 and the 
depiction of Ada’s synchronization mechanism. When an entry to a task is 
called, the procedure that called the entry waits at the rendezvous until the 
invoked task accepts the entry and finishes processing the accept statements. 
Only then can the procedure that called the entry continue processing. Figure 
3.3 depicts the two transitions required to model this control structure. The 
current code block is known by the Parser when the entry call statement is 


encountered. If the assumption that this is a correct Ada program is true, 
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KNOWN current code block 


entry code block 


UNKNOWN 


C) end entry code block 


UNKNOWN C) next code block UNKNOWN 


Figure 3.3 Known Places, Unknown Places, and Pseudo-Places 


PSEUDO 


then the task specification must have been parsed and at least the entry code 
block and the corresponding end entry code block are in the Symbol Table. It 
is not necessary for the locations to be known yet. In order to model the 
requirement for the invoking procedure to wait at the rendezvous until the 
accept statements of the entry are through being processed, it is necessary to 
use a pseudo-place that has no corresponding code block in source code. The 
second transition models the completion of the entry. The token from the 
pseudo-place and the end entry code block act together to enable the transition 
for the invoking procedure to continue processing. 

In this translater, the Parser emits known and unknown Petri net 
place information together with the type of control structure to be modeled to 
the Net Generator (Appendix D). For known Petri net places, the Parser 
emits the current code block number as provided by the Code Blocker. For 
unknown Petri net places, the Parser emits a pointer or access to the 


appropriate code block’s entry in the Symbol Table. The Net Generator is 


responsible for translating the control structure information into transitions 
between the known and unknown Petri net places. In addition, when it is 
necessary to use a pseudo-place to realize a model, the Net Generator grabs a 
unique location from the Code Blocker. During the course of this thesis, 
psuedo-places were only found necessary to realize models for procedure calls 
and entry calls. All other control structures were capable of being modeled by 
transitions between known and unknown Petri net places. 

One special control structure is used so often it deserves special 
mention. In the Net Generator, this special control structure is called 
CONNECT_ BLOCKS. Consider Figure 3.4 which represents the complete 
Petri net model for the previous example of Figure 3.1. The label 
ADD_ AGAIN, although it signifies a possible destination of a control 
structure’s execution, does not constitute a break in the sequential execution 
of MAIN. As the Parser knows the location associated with the begin code 
block, and the location associated with the ADD__AGAIN code block. The 
Parser simply emits these two known Petri net places to the Net Generator 
with the special control structure CONNECT__BLOCKS. 

The Net Generator stores the Petri net model in an abstract 
representation similiar to the abstract grammar described by Shatz and 
Cheng [Ref. 4]. The reason for utilizing an intermediate representation of the 
Petri net model is to give the Symbol Table and Parser an opportunity to 
resolve unknown Petri net places. By storing access variables to the unknown 
Petri net places in the Symbol Table as part of the abstract representation of 
the Petri net model, the Symbol Table will automatically update the location 


of unknown Petri net places referenced in the Net Generator. For the 
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procedure MAIN is procedure MAIN 
















type GRADE__BOOK is array (positive range 1..10) of 
natural; 

INDEX : natural, 

TOTAL: natural ; 

| AVERAGE: natural; 

| STUDENT: GRADE_ BOOK; 


silitee 


beyin 


» pe 


<<ADD_AGAIN>> 


- end it 
— 


<<CONTINUE> > 


begin 

| INDEX := 0; 

TOTAL:= 0; 

<<ADD__AGAIN>> 
INDEX := INDEX + 1; 
TOTAL:= TOTAL + 
STUDENTUNDEX); 
If(LNDEX = 10) then 
goto CONTINUE; 





else 
goto ADD__AGAIN; 
end ils 
<<CONTINUE> > 
AVERAGE := TOTAL / 10; 
end MAIN; 





end MAIN 


Figure 3.4 Transforming Control Structures to Transitions 


unknown places that signify the next code block to be encountered, the Net 
Generator simply waits for the Parser to emit the next control structure. If 
the preceding model has an abstract representation that ends with an 
unknown place that is not a Symbol! Table code block, the Net Generator 
chooses the next known code block location from the next Parser emission. As 


a correct Ada program is assumed and the question of Ada’s separate 
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compilation facility has not as yet been addressed , all unknown Petri net 
places must be resolved by the end of the source code’s parse. Only when the 
unknown places are resolved can we hope to generate a valid Petri net model 
of the source code. 

Another reason for utilizing an intermediate representation of the 
Petri net model is that different Petri net analyzers may require a different 
specific input language. By simply adding a translation algorithm to the Net 
Generator, the abstract representation of the model can be translated to 
various Petri net analyzer input languages. The Net Generator has one 


translator already defined for the P-NUT set of tools [Ref. 14]. 
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IV. “ADAFLOW” 


“AdaFlow” is a concept for a Petri net based, interactive Ada program 
analyzer. This preliminary work concentrates on, and suggests a 
methodology for, the automatic production of Petri net models of Ada 
programs. The products of this translation method have been tailored to 
conform to the input format of an existing Petri net analyzer entitled P-NUT. 
The first section of this chapter briefly describes the P-NUT suite of tools and 
the capabilities these tools offer. The following sections of this chapter 
describe in detail the products produced by the translator and the 


environment in which the translator and P-NUT perform. 


A. THE ANALYZER 

P-NUT isa set of tools developed by the Distributed Systems Project in 
the Information and Computer Science Department of the University of 
California, Irvine. The tools were constructed primarily to assist researchers 
in applying Petri net analysis techniques in the design of distributed systems. 
The P-NUT suite of tools creates and manipulates three types of objects: Petri 
nets, reachability graphs and execution traces. 

Petri nets are input to the system in textual form and are transformed by 
P-NUT into an internal representation ofa Petri net. It is the function of the 
translator to provide the Petri net in this textual form. For a complete 


discussion of P-NU'T’s input language, the reader is referred to Reference 14. 
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Reachability graphs represent the state-space of a Petri net while 
execution traces represent portions of the state space. P-NUT has the 
capability to produce, analyze and display both timed and untimed 
reachability graphs from the internal representation of a Petri net. P-NUT 
also allows an execution trace to be converted into a partial reachability graph 
which can be analyzed and displayed in the same manner as a reachability 
graph produced from the internal representation of a Petri net. 

The most powerful and innovative tool in P-NUT is a tool entitled 
Reachability Graph Analyzer (RGA) (Ref. 15). RGA reads the internal 
representation of a Petri net and its associated reachability graph and allows 
the user to do computer-assisted, interactive analysis, or “ask questions” 
about the model, using the language of first order predicate calculus with the 
addition of branching-time temporal logic operators. This interactive analysis 


capability is ideally suited to the concept of “AdaFlow”. 


B. THE TRANSLATOR PRODUCT 

The following example demonstrates the modeling capabilities of the 
proposed translation method by producing a simple railroad crossing model 
similar to the model analyzed by Leveson and Stolzy [Ref. 3]. 

Figure 4.1 illustrates the original model used by Leveson and Stolzy to 
demonstrate their technique for analysis of real-time systems. Although 
there is no combination of Ada control structures that can exactly duplicate 
the places and transitions of the model in Figure 4.1 the following Ada 
program realistically portrays how an Ada task may be written to handle such 


a problem: 
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Figure 4.1 A Petri Net Model of a Simple Railroad Crossing 


procedure RAIL_ROAD_ CROSSING is task body GATE__KEEPER is 
task COMPUTER is begin 
entry APPROACII,; loop 
entry DEPART; accept LOWER_ GATE do 
end COMPUTER; null; 
task GATE__ KEEPER is end LOWER_ GATE; 
entry LOWER_ GATE; accept RAISE__GATE do 
entry RAISE__GATE; null, 
end GATE__KEEPER,; end RAISE__GATE; 
task body COMPUTER is end loop; 
begin end GATE__KEEPER; 
loop begin 
accept APPROACII do COMPUTER.APPROACHL, 
null; < <BEFORE_CROSSING> > null, 
end APPROACII; <<WITIIIN _ CROSSING> > 
GATKE__ KEEPER. LOWER_ GATE, COMPUTER. DEPART; 
accept DEPART do <—<PAST_ CROSSING >= amalt 
null, end RAIL ROAD __CROSSING; 


end DIEPART; 
GATHE_KEBPPER. RAISE GATE, 
end loop; 
end COMPUTER: 
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The task entitled COMPUTER represents the software for the railroad 

crossing system, while the task entitled GATE_ KEEPER and the main 

procedure represent a test harness for the COMPUTER software. 
Assuming that this program is stored in a file entitled TRAIN2.ADA, a 


typical session with the “AdaF low” translator would begin: 


WELCOME TO ADAFLOW 


ENTER THE NAME OF AN ADA SOURCE FILE TO MODEL 
The user would respond with TRAIN2.ADA. The “AdaFlow” translator would 


notify the user: 


PARSING BEGINS... 


When “AdaFlow” has finished the translation, it gives the final message: 

_.. PARSE SUCCESSFUL 
and exits to the operating system. “AdaF low” creates two files. The first file 
is named A.OUT and it contains the Petri net model of the source code written 
in the P-NUT input language. The second file, PLACE.DAT, is provided for 
the user to relate Petri net places to lines of text in the source code. For the 


Ada program stored in TRAIN2.ADA, the A.OUT file would appear as: 


aut pi -> p2, p3, p19 :t17: p26, p25-> p27 
:t2: p3-> p4 :t18: p27-> p28, p29 
:t3: p4-> p5 :t19: p29-> p21, p30 
't4: p6, pS -> p7 20: p2=- p31 

:t5: p7-> p8, p9 at2 1. p31 22196932 
:t6: p9-> p22, p10 (22: p8,/p32-> p33 
:t7: p24, p10-> p11 :t23: p33 -> p34 

1t8: p12, p11-> p13 (24: p34-> p12, p35 
t9: p13-> p14, p15 :t25: p14, p35 -> p36 
:t10: p15-> p26, p16 :t26: p36-> p37 
:t11: p28, p16-> p17 11272p30, p18, p37-> p38 
etl2: pl7-> p5, pis <pl> 


ft13: pl9-> p20 
1t14: p20-> p21 
PEs. O22, p21-> p23 
:t16: p23-> p24, p25 
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The PLACE.DAT file relating locations in the source code to Petri net places 


would appear as: 


LOCATION CODE BLOCK LABEL STARTING LINE ENDING LINE 
p1 START 0 0 
p2 PROCEDURE CODE BLOCK 1 40 
p3 TASK CODE BLOCK 10 22 
p4 BEGIN SUBPROGRAM 11 12 
p5 LOOP BLOCK 12 13 
p6 ENTRY BLOCK 13 13 
p7 BEGIN ACCEPT STATEMENTS 13 14 
8 END ENTRY BLOCK 15 15 
p9 ENTRY CALL 15 16 
p10 WAIT RENDEZVOUS 0 0 
p11 ACCEPT STATEMENT 17 17 
p12 ENTRY BLOCK 17 17 
013 BEGIN ACCEPT STATEMENTS 17 18 
p14 END ENTRY BLOCK 19 19 
p15 ENTRY CALL 19 20 
016 WAIT RENDEZVOUS 0 0 
p17 END LOOP 21 21 
018 END SUBPROGRAM 22 22 
p19 TASK CODE BLOCK 23 33 
p20 BEGIN SUBPROGRAM 24 25 
p21 LOOP BLOCK 25 26 
p22 ENTRY BLOCK 26 26 
p23 BEGIN ACCEPT STATEMENTS 26 27 
p24 END ENTRY BLOCK 28 28 
p25 ACCEPT STATEMENT 29 29 
926 ENTRY BLOCK 29 29 
27 BEGIN ACCEPT STATEMENTS 29 30 
928 END ENTRY BLOCK 31 31 
p29 END LOOP 32 32 
p30 END SUBPROGRAM 33 33 
p31 BEGIN SUBPROGRAM 34 35 
p32 WAIT RENDEZVOUS 0 0 
p33 LABELLED BLOCK 36 37 
p34 LABELLED BLOCK 37 38 
935 WAIT RENDEZVOUS 0 0 
p36 LABELLED BLOCK 39 39 
p37 END SUBPROGRAM 40 40 
938 STOP 0 0 


The places that have a STARTING LINE and ENDING LINE of “0” are 


pseudo- places manufactured by the Net Generator. 
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Figure 4.2 illustrates the Petri net model of the train crossing produced 
by AdaFlow. By including a soivare test harness, a Petri net model for the 
software and the software’s environment was realized. This model is 
significant in that it is capable of system’s level, automated, interactive 
analysis for properties such as safety and deadlocks by utilizing RGA. 

It should be noted that “AdaFlow” assumes that the main procedure and 
all declared tasks activate simultaneously as modeled by the parbegin and 
parend control structure. Although not shown in Figure 4.2, execution ofa 
package’s sequence of statements or initialization before the parbegin has 
been modeled, but is not reachable. The first code block for a package’s 


sequence of statements is never linked to the rest of the model. 


C. ENVIRONMENT 
This preliminary work is written in Ada and utilizes the same front-end 

machine as the automated metric tool “AdaMeasure”. “AdaFlow” was 
originally written and compiled on the Meridian AdaVantage™ Compiler 
(Compiler Release 2.0). In order to install and operate the AdaVantage 
compiler, a target system must possess: 

e MS-DOS or PC-DOS version 2.1 or later. 

eA hard disk (typically 5MB or larger). 

640K bytes of Random Access Memory in the base memory area. 
In addition, an 8087 or 80287 floating point math coprocessor must be 
installed for programs that use floating point operations. “AdaFlow” 


currently does not require floating point operations. 


AdaVantage Is a trademark of Meridian Software Systems, Inc. 
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Figure 4.2 An AdaFlow Model of a Simple Railroad Crossing 
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Release 2.2 of P-NUT is only suitable for systems running a compatible 
version of 4.2bsd UNIX®. P-NUT was successfully installed at the Naval 
Postgraduate School on a SUN-3 workstation. To facilitate software analysis 
in the current form of “AdaF low”, the “AdaFlow” source code was transferred 
to the SUN workstation and was successfully recompiled using VADS® 
(Verdix Ada Development System, Version 5.5 for SUN-3) without 
modification. 

All the P-NUT software in release 2.2 is available free of charge from the 
Information and Computer Science Department of the University of 
California, Irvine. The point of contact for inquiries concerning P-NUT is 
Professor Rami Razouk. Release 2.2 includes the C source code and binaries 
for SUN-3’s. If operating in a different 4.2bsd UNIX environment, a Makefile 
is provided to facilitate recompilation of the source code. 

The Ada source code for “AdaF low” is available free of charge from the 
Computer Science Department of the Naval Postgraduate School. The point of 
contact for inquiries concerning “AdaFlow” is LCDR John Yurchak. 
Supplementary information concerning compilation of the source code is 


provided along with the source code. 


UNIX isa registered trademark of the Bell System 
VADS ts a registered trademark of the Verdix Corporation 


V. CONCLUSION 


Ada is the Department of Defense’s language of choice for programming 
embedded, real-time systems. The decision to use Ada has hastened the need 
for Ada-based, automated software engineering tools. The Petri net-based 
method proposed by Leveson and Stolzy for analyzing real-time systems has 
considerable merit; however, hand production of Petri net models for large, 
complicated systems is a tedious and error-prone process at best. This thesis 
has described and demonstrated that an efficient method exists for the 
automated translation of Ada source code to Petri nets. By adding additional 
features of the Ada language such as separate compilation and a library 
manager to “AdaF low”, the production and analysis of Petri net models on the 


systems scale is possible. 


A. THE FUTURE 

As the primary purpose of this thesis was to describe and demonstrate a 
methodology for the translation of Ada source code to Petri net models, not all 
control structures and features of the Ada language have actually been 
implemented in “AdaF low”; however, every design decision was made to 
facilitate the addition of these features. For example, the choice to utilize a 
scoped symbol table enables one to capitalize on Ada’s separate compilation 
facility at a later date. By adding a library manager to respond to Ada’s with 
statement, it is possible to maintain a library of Petri net models. These Petri 


net models could be of other Ada programs or pre-defined “environment 
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models” that could be referenced like Ada programs for systems testing of the 
software. It is envisioned that a library manager would operate by pre- 
loading the Net Generator with a package’s Petri Net model, and the Symbol! 
Table with a package’s scoped identifiers and properties. 

The Modified Ada Grammar, although able to parse a general Ada 
program, was developed specifically with metrics in mind. There are a 
number of ways to massage a grammar to appear LL(1). In their 
implementation of metrics, Neider and Fairbanks did not have to coordinate 
searching a scoped symbol table with the grammar. The massaged production 
rules for NAME reflect this bias. When the same production rules are used 
while trying to coordinate the search of a scoped symbol table, the grammar 
becomes hard to read and difficult to use. In “AdaFlow” only simplistic 
coordination efforts were taken with respect to the production rules for 
NAME. It was considered more important to demonstrate rather than perfect 
this capability. As searching the scoped symbol table is necessary to ascertain 
if an identifier is a procedure call, a function call, or a task entry, the logical 
candidate for change is the grammar. Future work should include re- 
massaging this portion of the Modified Ada Grammar to facilitate the 
coordination of searching a scoped symbol table. 

Discussion of analysis of the Petri net models produced by “AdaF low” has 
purposely been minimized. For the purpose of this thesis, it is sufficient to 
note that powerful automated analysis tools such as P-NUT’s RGA are 
currently available. As noted previously, RGA utilizes an input language of 
first order predicate calculus with the addition of branching-time temporal 


logic operators. Although this method of interactive analysis is powerful, it 
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limits the usefulness of the tool to those who have a firm understanding of 
predicate calculus. Future work on “AdaF low” should include the design and 
addition of a high-level, user-friendly interface to this analysis tool. This 
interface should be able to take user queries and formulate the mathematical 
expressions understood by RGA. 

In the train crossing example presented in Chapter IV, integration of 
“AdaFlow” software models with environment models was demonstrated by 
modeling a software test harness. Although this method served to 
demonstrate the principle of software analysis at the system level, the test 
harness has limitations in modeling the true environment the software may 
encounter. In related Petri net research at the Naval Postgraduate School, 
Lewis (Ref. 16) describes the analysis of a proposed, but never developed, real- 
time embedded missile software package. This analysis is conducted at the 
system level using Petri net models of the environment constructed by hand. 
Further research into using “AdaF low” to automate the integration of these 
environment models with the software under analysis is warranted. 

It is hoped that as the concept and features of “AdaFlow” are fully 
developed, this software tool will become a valuable aid in the design and 


testing of Ada programs for real-time, embedded applications. 
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APPENDIX A 
MODIFIED ADA GRAMMAR 


(9.10) (parser3) 
ABORT STATEMENT => NAME [, NAME]*; 


(9.5) (parser1) 
ACCEPT STATEMENT => identifier (EXPRESSION) ?] [FORMAL PART ?] 
[do SEQUENCE OF STATEMENTS end [identifier ?] 7] ; 


(4.3) (parser3) 
AGGREGATE (COMPONENT ASSOCIATION i COMPONENT ASSOCIATION ]* ) 


(4.8) (parser3) 
ALLOCATOR => SUBTYPE INDICATION {‘AGGREGATE ?] 


(3.6) (parser3) 
ARRAY TYPE DE FINITION => (INDEX CONSTRAINT of SUBTYPE INDICATION 


(5.2) (parser2) 
ASSIGNMENT OR PROCEDURE CALL => NAME: = EXPRESSION ; 
=> NAME; 


(4.1.4) (parser3) 
ATTRIBUTE DESIGNATOR => identifier [(EXPRESSION) ?] 
es = range [(EXPRESSION) ?] 
=> digits [(EXPRESSION) ?] 
=> delta (EXPRESSION) ?] 


(3.1) (parser1) 

BASIC DECLARATION = type TYPE DECLARATION 

a subtype SUBTYPE DECLARATION 
procedure PROCEDURE UNIT 
function FUNCTION UNIT 
package PACKAGE DECLARATION 
generic GENERIC DECLARATION 
IDENTIFIER DECLARATION 

task TASK DECLARATION 


UUUEUIUY 


(3.9) (parser1) 
BASIC DECLARATIVE ITEM = BASIC DECLARATIVE 
a - => REPRESENTATION CLAUSE 
= useWITH OR USE CLAUSE 
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(10.1) (parser0) 
BASIC UNIT => LIBRARY _U NIT 
_ => SUBUNIT 


(4.5) (parser4) 

BINARY ADDING OPERATOR => + 
me = = 

=> & 

(5.6) (parser1) 

BLOCK STATEMENT => [declare DECLARATIVE PART ?] begin 
i SEQUENCE OF STATEMENTS [exception 

[EXCEPTION HANDLER] * ?] ?] end [identifier ?] ; 


(5.4) (parser1) 
CASE STATEMENT => EXPRESSION is [CASE STATEMENT ALTERNATIVE} * end case ; 


(5.4) (parser1) 
CASE STATEMENT ALTERNATIVE = when CHOICE [| CHOICE}* = > 
SEQUENCE OF STATEMENTS 


(3.7.3) (parser3) 

CHOICE= EXPRESSION [..SIMPLE EXPRESSION ?] 
= EXPRESSION [CONSTRAINT ?] 
=> others 


(10.1) (parser0) 
COMPILATION => [COMPILATION _ UNIT] . 


(10.1) (parser0) 
COMPILATION UNIT => CONTEXT CLAUSE BASIC_UNIT 


(4.3) (parsers) 
COMPONENT ASSOCIATION = [CHOICE [| CHOICE]* = > ?] EXPRESSION 


(3.7) (parser2) 
COMPONENT DECLARATION => IDENTIFIER LIST ; SUBTYPE INDICATION 
[: = EXPRESSION ?]; 


(3.7) (parser2) 
COMPON ENT LIST => [COMPONENT DECLARATION]* [VARIANT PART ?] 
=> null; a = 


(5.1) (parser1) 
COMPOUND STATEMENT if1F STATEMENT 

- case CASE STATEMENT 
LOOP STATEMENT 
BLOCK STATEMENT 
accept ACCEPT STATEMENT 


SELECT STATEMENT 


UUUIUY 
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(3.2) (parser2) 
CONSTANT _ TERM => a aaa TYPE __DEFINITION [: = EXPRESSION ?]; 
=> := EXPRESSION; 


(3.3.2) (parser3) 

CONSTRAINT = range RANGES 
=> range <> 
= digits FLOATING _ OR FIXED POINT CONSTRAINT 
=> deltaFLOATING OR FIXED _ POINT | ~ CONSTRAINT 
=> (INDEX CONSTRAINT = 


(10.1) (parser0) 
CONTEXT CLAUSE => [with WITH OR USE CLAUSE 
fuse WITH _OR__USE__CLAUSE])* |" 


(3.9) (parser1) 
DECLARATIVE PART=> [BASIC DECLARATIVE _ITEM]* [LATE R_ DECLARATIVE _ITEM]* 


(9.6) (parser3) 
DELAY STATEMENT => SIMPLE EXPRESSION ; 


(6.1) (parser2) 
DESIGNATOR => identifier 
= string literal 


(3.6) (parser3) 
DISCRETE RANGE => RANGES [CONSTRAINT ?] 


(3.7.1) (parser2) 
DISCRIMINANT PART => (DISCRIMINANT SPECIFICATION 
[; DISCRIMINANT __SPECIFICATION]* ) 


(3.7.1) (parser2) 
DISCRIMINANT SPECIFICATION => IDENTIFIER LIST > NAME [: = EXPRESSION ?] 


(9.5) (parser2) 
ENTRY DECLARATION => entry identifier [(DISCRETE RANGE) ?] 
[FORMAL PART 2]; 


(3.5.1) (parser4) 
ENUMERATION _LITERAL => identifier 
= character literal 


(3.5.1) (parser4) 
ENUMERATION TYPE DEFINITION => (ENUMERATION LITERAL 
[, ENUMERATION __LITERAL]* ) 


(11.1) (parser2) 


EXCEPTION CHOICE => NAME 
=> others 
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(11.2) (parser1) 
EXCEPTION HANDLER = when EXCEPTION CHOICE [| EXCEPTION CHOICE]* 
a = >SEQUENCE OF STATEMENTS 


(8.5) (parser2) 
EXCEPTION _ TAIL =>; 
=> renames NAME ; 


(5.7) (parser3) 
EXIT STATEMENT => [NAME ?] [when EXPRESSION ?] ; 


(4.4) (parser3) 
EXPRESSION => RELATION [RELATION TAIL ?] 


(4.4) (parser3) 

FACTOR => PRIMARY [** PRIMARY ?] 
= abs PRIMARY 
=> not PRIMARY 


(3.5.7) (parser3) 
FLOATING OR FIXED POINT CONSTRAINT => SIMPLE EXPRESSION [range RANGES 
?] "—e a - ioe 


(6.4) (parser4) 
FORMAL PARAMETER = identifier = > 


(6.1) (parser2) 
FORMAL PART =>(PARAMETER SPECIFICATION [; PARAMETER _SPECIFICATION]* ) 


(6.1) (parser1) 
FUNCTION UNIT => DESIGNATOR [FORMAL PART ?] return NAME is 
mn SUBPROGRAM BODY 
=> DESIGNATOR [FORMAL PART ?] return NAME ; 
=> DESIGNATOR [FORMAL PART ?] return NAME renames NAME ; 
=> DESIGNATOR is SUBPROGRAM BODY 


(12.1) (parser2) 
GENERIC _ACTUAL_ PART => (GENERIC ASSOCIATION [, GENERIC _ASSOCIATION]* ) 


(12.1) (parser2) 
GENERIC ASSOCIATION =» [GENERIC_FORMAL_ PARAMETER ?] EXPRESSION 


(12.1) (parser1) 
GENERIC_DECLARATION => [GENERIC PARAMETER DECLARATION ]* 
GENERIC FORMAL PART ~ 


(12.1) (parser2) 
GENERIC FORMAL PARAMETER = identifier = > 
= string literal = > 
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(12.1) (parser1) 
GENERIC FORMAL PART => procedurePROCEDURE UNIT 
= a => function FUNCTION UNIT 
= package PACKAGE DECLARATION 


(12.1) (parser1) 
GENERIC PARAMETER DECLARATION = IDENTIFIER LIST: [MODE ?] NAME 
S [: = EXPRESSION ?]; 
=> type private [DISCRIMINANT PART ?] 
isPRIVATE TYPE DECLARATION ; 
=> type private [DISCRIMINANT PART ?] 
isGENERIC TYPE DEFINITION; 
=> with procedure PROCEDURE UNIT 
=> with function FUNCTION UNIT 


(12.1) (parser2) 

GENERIC TYPE DEFINITION (<>) 

a a range <> 

digits <> 

delta <> 

array ARRAY TYPE DEFINITION 


access SUBTYPE | NDICATION 


UVUUYIIY 


(5.9) (parser3) 
GOTO STATEMENT => NAME ; 


(3.2) (parser2) 
IDENTIFIER DECLARATION =>IDENTIFIER LIST: IDENTIFIER DECLARATION TAIL 


(3.2) (parser2) 
IDENTIFIER DECLARATION TAIL=> exception EXCEPTION TAIL 
r = => constant CONSTANT TERM 
=> array ARRAY TYPE DEFINITION 
[: = EXPRESSION 7]; 
=> NAME IDENTIFIER TAIL 


(3.2) (parser2) 
IDENTIFIER LIST => identifier [, identifier]* 


(3.2) (parser2) 
IDENTIFIER TAIL = [CONSTRAINT ?][: = EXPRESSION ?]; 
=> [renames NAME ?]; 


(5.3) (parser1) 
IF STATEMENT => EXPRESSION thenSEQUENCE OF STATEMENTS 
a [elsif EXPRESSION then SEQUENCE OF STATEMENTS]* [else 
SEQUENCE OF STATEMENTS ?] end if; 


(3.6) (parser3) 
INDEX CONSTRAINT => DISCRETE RANGE [ DISCRETE RANGE]* ) 


ol 


(3.5.4) (parser3) 
INTEGER TYPE DEFINITION => range RANGES 


(5.5) (parser3) 
ITERATION SCHEME = while EXPRESSION 
a = for LOOP PARAMETER _ SPECIFICATION 


(5.1) (parser2) 
LABEL=> << identifier >> 


(3.9) (parser1) 
LATER DECLARATIVE ITEM => PROPER BODY 
— = => generic GENERIC DECLARATION 
=> useWITH OR USE CLAUSE 


(4.1) (parsers) 
LEFT PAREN NAME TAIL => [FORMAL PARAMETER ?] EXPRESSION [..EXPRESSION ?} 
= i = [, [FORMAL PARAMETER ?] EXPRESSION 
[.. EXPRESSION ?]]* ) [NAME TAIL]* 


(10.1) (parser0O) 
LIBRARY UNIT => procedure PROCEDURE UNIT 
= => function FUNCTION UNIT 
=> package PACKAGE DECLARATION 
=> generic GENERIC DECLARATION 


(5.5) (parser3) 
LOOP_ PARAMETER _ SPECIFICATION = identifier in [reverse ?] DISCRETE RANGE 


(5.5) (parser1) 
LOOP STATEMENT => [ITERATION SCHEME ?] loop 
SEQU ENCE OF STATEMENTS end loop [identifier ?] ; 


(6.1) (parser2) 

MODE => [in ?] 
=> inout 
=> out 


(4.5) (parser4) 
MULTIPLYING OPERATOR = * 
_ — i 
=> mod 
=> rem 


(4.1) (parser3) 

NAME => identifier [NAME TAIL ?] 
= character literal [NAME TAIL ?] 
=> string literal[NAME TAIL ?] 
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(4.1) (parser3) 
NAME TAIL = (LEFT PAREN NAME. TAIL 
< => SELECTOR[NAME_ TAIL]* 
=> 'AGGREGATE [NAME TAIL]* 
=> ‘ATTRIBUTE DESIGNATOR[NAME TAIL]* 


(7.1) (parser1) 
PACKAGE DECLARATION = body identifier is SUBPROGRAM BODY 
= identifier is PACKAGE TAIL END 
=> identifier renames NAME; 


(7.1) (parser1) 
PACKAGE _ TAIL END=> newNAME [GENERIC ACTUAL PART ?]; 
~ «=> [BASIC DECLARATIVE ITEM]* [private 
[BASIC DECLARATIVE ITEM]* ?) end [identifier 7] ; 


(6.1) (parser2) 
PARAMETER SPECIFICATION => IDENTIFIER LIST: MODE NAME [: = EXPRESSION ?] 


(4.4) (parser3) 

PRIMARY => numeric literal 
null = 
string literal 
new ALLOCATOR 
NAME 
AGGREGATE 


HVYUYUUY 


(7.4) (parser2) 
PRIVATE TYPE DECLARATION => [limited 2] private 


(6.1) (parser1) 
PROCEDURE UNIT => identifier [FORMAL PART ?] is SUBPROGRAM _ BODY 
i => identifier [FORMAL PART ?]; 
=> identifier [FORMAL PART ?] renames NAME ; 


(3.9) (parser 1) 
PROPER BODY = procedurePROCEDURE UNIT 
— => functionFUNCTION UNIT 
= package PACKAGE DECLARATION 
=> task TASK DECLARATION 


(3.5) (parser3) 
RANGES =>SIMPLE EXPRESSION [..SIMPLE EXPRESSION ?] 


(11.3) (parser3) 
RAISE STATEMENT => [NAME ?] ; 


(13.4) (parser2) 

RECORD _ REPRESENTATION __ CLAUSE => [atmod SIMPLE EXPRESSION ?] 
[NAME at SIMPLE EXPRESSION range 
RANGES]*end record ; 
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(3.7) (parser2) 
RECORD TYPE DEFINITION =» COMPONENT LIST end record 


(4.4) (parser3) 
RELATION => SIMPLE EXPRESSION [SIMPLE EXPRESSION TAIL ?] 


(4.4) (parser3) 
RELATION TAIL = [and [then ?] RELATION]* 
a = for [else ?] RELATION]* 
=> [xor RELATION]* 


(4.5) (parser4) 
RELATIONAL OPERATOR 


— 
i) 


> 
=> 
=> 
“= 
= 
=> 


VVAA 


(13.1) (parser2) 
REPRESENTATION CLAUSE = for NAME use record 
7 RECORD REPRESENTATION CLAUSE 
=> for NAME use [at ?] SIMPLE EXPRESSION; 


(5.8) (parser3) 
RETURN STATEMENT => [EXPRESSION ?] ; 


(9.7.1) (parser1) 
SELECT ALTERNATIVE = [when EXPRESSION = > ?] accept ACCEPT STATEMENT 
- [SEQUENCE OF STATEMENTS?) | 
=> [when EXPRESSION = > ?]delay DELAY STATEMENT 
[SEQUENCE OF STATEMENTS?] | 
= [when EXPRESSION = > ?] terminate ; 


(9.7.1) (parser1) 
SELECT ENTRY CALL => elseSEQUENCE OF STATEMENTS 
= 4 => ordelay DELAY STATEMENT 
[SEQUENCE OF STATEMENTS ?] 


(9.7) (parser1) 
SELECT STATEMENT => selectSELECT STATEMENT TAIL[SELECT ENTRY CALL ?] 
end select ; i wa _ 


(9.7.1) (parser1) 
SELECT STATEMENT TAIL => SELECT ALTERNATIVE [or SELECT ALTERNATIVE]* 
=> NAME; [SEQU ENCE OF STATEMENTS 2) 


(4.1.3) (parser4) 
SELECTOR = identifier 
= character literal 


o4 


=> string literal 
=> all 


(5.1) (parser1) 
SEQU ENCE OF STATEMENTS = ([STATEMENT]' 


(4.4) (parser3) 
SIMPLE _ EXPRESSION a [+ ?] TERM [BINARY ADDING OPERATOR TERM]* 
=> [-?] TERM [BINARY ADDING _ OPERATOR TERM]* 


(4.4) (parser3) 
SIMPLE EXPRESSION TAIL = RELATIONAL OPERATOR SIMPLE _ EXPRESSION 
a » => [not ?] in RANGES 
=> [not ?] in NAME 


(5.1) (parser2) 
SIMPLE STATEMENT => null; 

- = ASSIGNMENT OR PROCEDURE CALL 
=> exitEXIT STATEMENT 

=> return RETURN STATEMENT 

=> gotoGOTO STATEMENT 

=> delay DELAY STATEMENT 

= abort ABORT STATEMENT 

= 


raise RAISE STATEMENT 


(5.1) (parser1) 
STATEMENT => [LABEL ?] SIMPLE STATEMENT 
= [LABEL ?] COMPOUND STATEMENT 


(6.3) (parser1) 

SUBPROGRAM BODY = newNAME [GENERIC ACTUAL PART ?]; 

-_ separate ; = i 

<> 

[DECLARATIVE PART ?][beginSEQUENCE OF STATEMENTS 
[exception [EXCEPTION HANDLER] * 2]?] end [DESIGNATOR ?] ; 
NAME ; 


uo Guy 


(3.3.2) (parser2) 
SUBTYPE DECLARATION = identifier is SUBTYPE INDICATION ; 


(3.3.2) (parser3) 
SUBTYPE INDICATION = NAME [CONSTRAINT ?] 


(10.1) (parserQ) 
SUBUNIT = = separate (NAME) PROPER BODY 


(9.1) (parser1) 
TASK DECLARATION = body identifier is SUBPROGRAM BODY ; 
=> [type ?] identifier [is [ENTRY DECLARATION]* 
[REPRESENTATION CLAUSE]* end [identifier ?] 7]; 


O90 


(4.4) (parser3) 
TERM = FACTOR [MULTIPLYING OPERATOR FACTOR]* 


(3.3.1) (parser2) 
TYPE DECLARATION => identifier [DISCRIMINANT PART ?] 
= [isPRIVATE TYPE DECLARATION 2]; 
=> identifier [DISCRIMINANT PART ?] 
(is TYPE DEFINITION ?]; 


(3.3.1) (parser2) 

TYPE DEFINITION => ENUMERATION TYPE DEFINITION 

= INTEGER TYPE DEFINITION 

digits FLOATING OR FIXED POINT CONSTRAINT 
delta FLOATING OR FIXED POINT CONSTRAINT 
array ARRAY TYPE DEFINITION 

record RECORD TYPE DEFINITION 
accessSUBTYPE INDICATION 

new SUBTYPE INDICATION 


HVUUGIGY 


(3.7.3) (parser2) 
VARIANT => ~~ when CHOICE [| CHOICE]* = > COMPONENT _LIST 


(3.7.3) (parser2) 
VARIANT PART => case identifier is [VARIANT]’ end case; 


(10.1.1) (parser2) 
WITH OR USE CLAUSE => identifier [, identifier}* ; 
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APPENDIX B 
“ADAFLOW” PROGRAM LISTING - MAIN 


— ee SEE ERE REE EEE EES SESE RSET ERS ES ER EE ESE SESE SESE ESE SESE SESE SESE SSE 


Peer ILe: ADAF LOW a, 
-- MODULE NAME: PROCEDURE MAIN aia 
-- FILE NAME: MAIN.ADA == 


semeOATE CREATED: O02 FEB 88 = 
-- LAST MODIFIED: 28 APR 88 ai 


-- AUTHOR(S): LT ALBERT J. GRECCO, USN ae 


-- DESCRIPTION: This procedure is the highest level procedure -- 
i of ADAFLOW. It queries the user for an ADA a 
oe program to model, sets up the token matcher, = 
=o Starts the parser through the ADA program, and -- 
= translates the results of the parse to P-NUT a 
a code. a 


——- SFSFFSSFSSFSSSSESTTSTESSTET SSPE ST TSE TSE STS SE SSSTETSSERSSSSESPSESSASVSSVSVBWBWSAPsweseseB__ 


with TOKEN MATCHER, CODE BLOCKER, SYMBOL_TABLE, 
NET GENERATOR, PARSER, TEXT_IO; 


procedure MAIN is 
SOURCE _CODE_FILE : string (1..80) := (others => ' '); 
SOURCE_CODE_FILE_ LENGTH : natural; 


procedure GET FILE NAME is 
UNKNOWN NAME : exception; 
use TEXT_IO; 
begin 
put_line("WELCOME TO ADAFLOW"); new_line; 
put_line("ENTER THE NAME OF AN ADA SOURCE FILE TO MODEL"); new_line; 
SOURCE CODE FILE := (others => ° *); 
get_line( SOURCE _CODE_FILE, SOURCE _CODE_FILE_LENGTH); new_line; 
if (SOURCE CODE_FILE_LENGTH = 0) then 
raise UNKNOWN NAME ; 
else 
put_line(SOURCE CODE _FILE(1..SOURCE CODE_FILE_LENGTH)); 
end if; 
end GET FILE NAME; 
begin 


o7 


GET_FILE_NAME; 
TOKEN_MATCHER.SET_UP_TOKEN_MATCHER( SOURCE_CODE_FILE(1.. 
SOURCE_CODE_FILE_LENGTH)); 


TEXT_IO0.put_line("PARSING BEGINS . . . "); 

if PARSER.IS PARSED then 
TEXT_I0.put_line(”. . . PARSE SUCCESSFUL.) 
NET GENERATOR. TRANSLATE_TO PEANUT; 

else 
TEXT_1O.put_line(”. . 2 PARSE UNSUCCESSFUL”): 


CODE BLOCKER.CLEAR_CODE_ BLOCKER; 
NET _GENERATOR.RESET_NET_GENERATOR; 
end if; 
SYMBOL_TABLE.CLEAR_SYM_TAB; 
TOKEN MATCHER.RELEASE_ TOKEN _MATCHER; 
exception 
when others => 
TEXT_IO0.put_line("UNABLE TO MODEL ADA SOURCE CODE"); 
TEXT_I0.put_line(". . . PARSE UNSUCCESSFUL}: 
CODE _BLOCKER.CLEAR_CODE BLOCKER; 
NET GENERATOR. RESET _NET_GENERATOR; 
SYMBOL_TABLE.CLEAR_SYM_TAB; 
begin 
TOKEN MATCHER.RELEASE_ TOKEN MATCHER; 
exception 
when others => null; 
end; 
end MAIN; 


08 


APPENDIX C 
“ADAFLOW” PROGRAM LISTING - PARSER 


——FSSFSSSSSF STS SSSFKESFE SE SF SFSFSSFSFS SASS SSFSSSF SSE SSTE SSS SSA SSSESSSSASESAARAAs*s_ 


ae LCE ADAFLOW a 
-- MODULE NAME: PACKAGE PARSER =< 
seer ile NAME: PARSER .ADS see 


Semen ve CREATED: 18 FEB 88 Pm 
-- LAST MODIFIED: 28 APR 88 Sz 


-- AUTHOR(S): LT ALBERT J. GRECCO, USN -- 


-- DESCRIPTION: This package defines the only interfaces to a 
a to the parser. Packages PARSER 0 through PARSER_4 =< 
ae exist only as local packages to package PARSER and are -- 
= not user accessable. 2S 


——FSSSSSSSSSSSSSSSFS SSS SST SESESS STS SSTSEASSSSTSFSSSESESCASTSSESSARESVRHEAAA*AS*A*A**W*__ 


package PARSER 1s 
function IS PARSED return boolean; 
-- pre - TOKEN MATCHER, SYMBOL_TABLE, CODE_BLOCKER, and NET_GENERATOR are 
= initialized. 
-- post - If the file being parsed is a valid ADA program, IS_PARSED 
a is TRUE else IS _PARSED is FALSE. 
end PARSER; 
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——FSFFSSFSFFSSSFSFSSFSFSSSSSSESSFSTE SS SESS SS SEFSESFSFFS FESS SESSESSE SESE SSSFGESIESSAIF. 


=> iE? ADAFLOW == 
-- MODULE NAME: PACKAGE PARSER =< 
=-- FILE NAME: PARSER. ADB a 


-- DATE CREATED: 18 FEB 88 mi 
-- LAST MODIFIED: 28 APR 88 ae 


-- AUTHOR(S): LT ALBERT J. GRECCO, USN 23 


-- DESCRIPTION: This package implements the only interfaces to -- 
== the parser. a= 


PPERE ESE REESE SESE EEE SEES ESSE EEE SSE ESSE ESE SESE SES ES ESE SES EES ES ESE ESE SE ES ee 


with PARSER_0, PARSER 4; 


package body PARSER is 
function IS_PARSED return boolean is 
-- pre - TOKEN_MATCHER, SYMBOL_TABLE, CODE_BLOCKER, and NET_GENERATOR have 
== been initialized. 
-- post - If the file being parsed is a valid ADA program, IS_PARSED 
rae is TRUE else IS_PARSED is FALSE. 
begin 
return PARSER _0.COMPILATION; 
exception 
when PARSER _4.PARSER_ERROR => 
return FALSE; 
when others => 
raise; 
end IS PARSED; 
end PARSER; 
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—— SSSSSSFSSFSSSSSSFSSSSSSSSSESSSSFSSESFSSF SSS SSSSFSFSSC SSS SSE SS SSE SSSsSSsss sess __ 


De LITLE: ADAF LOW =a 
-- MODULE NAME: PACKAGE PARSER_0O ae 
Se FILE NAME: PARSERO.ADS == 


SeeeUATE CREATED: 18 FEB 88 = 
-- LAST MODIFIED: 28 APR 88 =e 


-- AUTHOR(S): LT ALBERT J. GRECCO, USN -- 


-- BASED ON A MODIFIED ADA GRAMMAR DEVELOPED BY: an 
sta LCDR JEFFREY L. NIEDER, USN == 
am LT KARL S. FAIRBANKS, JR., USN ie 
=o LCDR PAUL M. HERZIG, USN aa 


-- DESCRIPTION: This package defines the functions that oe 
22 make up the highest level productions for a top-down, me 
== recursive descent parser. Ss 


——FFSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSESSSSSSSSSSFSSSSSE SSS SES SSSSesssesess_. 


package PARSER_O is 
function COMPILATION return boolean; 
function COMPILATION UNIT return boolean; 
function CONTEXT CLAUSE return boolean; 
function BASIC_UNIT return boolean; 
function LIBRARY _UNIT return boolean; 
function SUBUNIT return boolean; 

end PARSER_0; 
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——_ SFSSSFSTFFSSTSTS STE SS SSS SE SSS SS SES FSS ST STE STE SSS SL SSSSTESHSEVMSSESH SSS SSB TSTE 


ot —— 


==) OV Be ADAF LOW as 
-- MODULE NAME: PACKAGE PARSER _0 25 
-- FILE NAME: PARSERO .ADB a 


== (GATE CREATED: 18 FEB 88 a 
-- LAST MODIFIED: 28 APR 88 td 


== AUTHORGS): LT ALBERT J. GRECCO, USN == 


-- BASED ON A MODIFIED ADA GRAMMAR DEVELOPED BY: == 
a LCDR JEFFREY L. NIEDER, USN os 
== LT KARL S. FAIRBANKS, JR., USN oe 
a LCDR PAUL M. HERZIG, USN == 


-- DESCRIPTION: This package implements the functions that oe 
= make up the highest level productions for a top-down, Te 
== recursive descent parser. Each function is preceded == 
ae by the grammar productions they are implementing. 7 


PPE SEEESE EERE SESE ESE ESSE ES EES EEE SESE SESE SEES EERE SESE SESE SESE EEE SE EEE 


with PARSER_1, PARSER 2, PARSER 3, PARSER 4, TOKEN MATCHER; 


package body PARSER_O is 
package TM renames TOKEN _MATCHER; 
package Pi renames PARSER 1; 
package P2 renames PARSER 2; 
package P3 renames PARSER_3; 
package P4 renames PARSER_4; 


-- COMPILATION --> [COMPILATION _UNIT]+ 
function COMPILATION return boolean is 
begin 

if (P4.PRINT_CALLS) then 

P4.OUT_PUT( "COMPILATION" ); 
end if; 

if (COMPILATION UNIT) then 

while (COMPILATION UNIT) loop 
null; 
end loop; 
return (TRUE); 
else 
return (FALSE); 

end if; 

end COMPILATION; 


62 


-- COMPILATION_UNIT --> CONTEXT_CLAUSE BASIC_UNIT 
function COMPILATION_UNIT return boolean is 
begin 

if (P4.PRINT_CALLS) then 

P4,OUT_PUT( "COMPILATION UNIT"); 
end if; 

if (CONTEXT_CLAUSE) then 

if (BASIC_UNIT) then 
return (TRUE); 
else 
return (FALSE); 
end if; 
else 
return (FALSE); 

end if; 

end COMPILATION _UNIT; 


-- CONTEXT_CLAUSE --> [with WITH_OR_USE_CLAUSE [use WITH_OR_USE_CLAUSE]* ]* 
function CONTEXT_CLAUSE return boolean is 
begin 

if (P4.PRINT_ CALLS) then 

P4.QUT_PUT( "CONTEXT_CLAUSE"); 
end if; 
while (TM.MATCH(TM.TOKEN_WITH)) loop 
if not (P2.WITH_OR_USE_CLAUSE) then 
P4.SYNTAX_ERROR( "Context clause"); 
end if; 
while (TM.MATCH(TM.TOKEN_USE)) loop 
if not (P2.WITH OR USE CLAUSE) then 
P4.SYNTAX_ERROR( "Context clause"); 


end if; 
end loop; -- inner while loop 
end loop; -- outer while loop 


return (TRUE); 
end CONTEXT CLAUSE; 


— em ew em em — ee we = = = ee = = = = oe ee 2 ee ee oe ee ew ee ee we ee ee ee ee ee ew ee ee ee ee ee wee we ee ee eH = 


-- BASIC_UNIT --> LIBRARY_UNIT 
oe --> SUBUNIT 
function BASIC _UNIT return boolean is 
begin 
if (P4.PRINT_CALLS) then 
P4.OUT_PUT("BASIC_UNIT"); 
end if; 
if (LIBRARY_UNIT) then 
return (TRUE); 
elsif (SUBUNIT) then 
return (TRUE); 
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else 
return (FALSE); 
end if; 
end BASIC_UNIT; 


-- LIBRARY_UNIT --> procedure PROCEDURE_UNIT 
a= --> function FUNCTION _UNIT 
i --> package PACKAGE DECLARATION 
<= --> generic GENERIC DECLARATION 
function LIBRARY_UNIT return boolean is 
begin 
if (P4.PRINT_CALLS) then 
P4.OUT_PUT("LIBRARY_UNIT"); 
end if; 
if (TM.MATCH(TM. {Gn . PROCEDURE)) then 
if (P1.PROCEDURE_UNIT) then 
return (TRUE); 


else 
P4.SYNTAX_ERROR( "Library unit"); 
end if; -- if procedure_unit statement 


elsif (TM.MATCH(TM. TOKEN _FUNCTION)) then 
if (P1.FUNCTION_UNIT) then 
return (TRUE); 


else 
P4.SYNTAX_ERROR( "Library unit"); 
end if; -- if function_unit statement 


elsif (TM.MATCH(TM. TOKEN PACKAGE)) then 
if (P1.PACKAGE DECLARATION) then 
return (TRUE); 


else 
P4.SYNTAX_ERROR( "Library unit"); 
end if; -- if package _declaration 


elsif (TM.MATCH(TM. TOKEN GENERIC)) then 
if (P1.GENERIC_DECLARATION) then 
return (TRUE); 
else 
P4.SYNTAX_ERROR("“Library unit"); 
end if; -- if generic_declaration 
else 
return (FALSE); 
end if; 
end LIBRARY UNIT; 


- SUBUNIT --> separate (NAME) PROPER BODY 
function SUBUNIT return boolean 1s 
begin 
1f (P4.PRINT CALLS) then 
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P4.OUT PUT("SUBUNIT"); 
end if; 
if (TM.MATCH(TM. TOKEN SEPARATE)) then 
if (TM.MATCH(TM.TOKEN LEFT _PAREN)) then 
if (P3.NAME) then 
if (TM.MATCH( TM. TOKEN RIGHT _PAREN)) then 
if (P1.PROPER BODY) then 
return (TRUE); 
else 
P4.SYNTAX_ERROR("Subunit"); 
end if; -- if proper_body statement 
else 
P4.SYNTAX_ERROR("Subunit"); 
end if; -- if bypass(token_right_paren) 
else 
P4.SYNTAX_ERROR("Subunit"); 
end if; -- if name statement 
else 
P4.SYNTAX_ERROR( "Subunit"); 
end if; -- if bypass(token_left_paren) 
else 
return (FALSE); 
end if; -- if bypass(token_separate) 
end SUBUNIT; 


end PARSER_0; 
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— = FF SSS SSSSTS SSE SSS SST SSE STFS SFE SSS SESS SSS SS SH SFE STS SSS SS SSHFSsSE Sess ssi_ 


LETEE: ADAF LOW 


MODULE NAME: 
FILE NAME: 


PACKAGE PARSER 1 
PARSER1.ADS 


DATE CREATED: 
LAST MODIFIED: 


18 FEB 88 
28 APR 88 
AUTHOR(S): LT ALBERT J. GRECCO, USN 
BASED ON A MODIFIED ADA GRAMMAR DEVELOPED BY: 
LCDR JEFFREY L. NIEDER, USN 


LT KARL S. FAIRBANKS, JR., USN 
LCDR PAUL M. HERZIG, USN 


DESCRIPTION: This package defines the functions 
that make up the top level productions for a top-down, 
recursive descent parser. 


—a~- SFSSSSSFSSSSSS SSS SST SSE SS SSSSSSSSTSE SS SSSSSFESSE STE SS SSSSsSS SESE SVsESsEsE SF 


package PARSER_1 is 
function GENERIC_DECLARATION return boolean; 
function GENERIC PARAMETER DECLARATION return boolean; 


function 
function 
function 
function 
function 
function 
function 
function 
function 
function 
function 
function 
function 
function 
function 
function 
function 
function 
function 
function 
function 
function 
function 
function 
function 


GENERIC_FORMAL_PART return boolean; 
PROCEDURE_UNIT return boolean; 
SUBPROGRAM BODY return boolean; 
FUNCTION_UNIT return boolean; 

TASK DECLARATION return boolean; 
PACKAGE DECLARATION return boolean; 
PACKAGE _TAIL_END return boolean; 
DECLARATIVE PART return boolean; 
BASIC_DECLARATIVE_ITEM return boolean; 
BASIC_DECLARATION return boolean; 
LATER DECLARATIVE_ITEM return boolean; 
PROPER BODY return boolean; 
SEQUENCE OF STATEMENTS return boolean; 
STATEMENT return boolean; 

COMPOUND STATEMENT return boolean; 
BLOCK_STATEMENT return boolean; 
IF_STATEMENT return boolean; 

CASE STATEMENT return boolean; 

CASE STATEMENT ALTERNATIVE return boolean; 
LOOP STATEMENT return boolean; 
EXCEPTION HANDLER return boolean; 
ACCEPT STATEMENT return boolean; 
SELECT STATEMENT return boolean; 
SELECT STATEMENT TAIL return boolean; 
SELECT ALTERNATIVE return boolean; 
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——SFSSSSSSSSSS SSS SS SSS SSSSSSSSSTSS SSS SSS SSE SS FS SSSSESSSSSTSSHSSSSESSESSEBSE _ 


==" ULE ADAFLOW == 
~- MODULE NAME: PACKAGE PARSER_1 = 
-- FILE NAME: PARSER1.ADB ce 


-=- DATE CREATED: 18 FEB 88 = 
-- LAST MODIFIED: 28 APR 88 a 


-- AUTHOR(S): LT ALBERT J. GRECCO, USN -- 


-- BASED ON A MODIFIED ADA GRAMMAR DEVELOPED BY: == 
a LCOR JEFFREY L. NIEDER, USN == 
aS LT KARL S. FAIRBANKS, JR., USN a 
== LCDR PAUL M. HERZIG, USN == 


-- DESCRIPTION: This package implements the functions == 
mie that make up the top level productions for a top-down, -- 
a recursive descent parser. Each function is preceded oS 
== by the grammar productions they are implementing. == 


——~ FFSSSSSSSSS SSS SSS SS SSS SS SSS SS SSSESSE STS SS SSESSESSSSSSSSSSSSSVSESEVssEsVs___ 


with PARSER 2, PARSER_3, PARSER 4, 
TOKEN MATCHER, TOKEN SCANNER, CODE_BLOCKER, 
SYMBOL_TABLE, NET_GENERATOR; 


package body PARSER 1 is 
package TM renames TOKEN _MATCHER; 
package P2 renames PARSER 2; 
package P3 renames PARSER_3; 
package P4 renames PARSER_4; 


IS_MAIN_PROGRAM : boolean := TRUE; 


-~- GENERIC DECLARATION --> [GENERIC_PARAMETER_ DECLARATION ]* 
a GENERIC_FORMAL_PART 
function GENERIC DECLARATION return boolean is 
begin 
if (P4.PRINT CALLS) then 
P4.OUT_PUT( "GENERIC DECLARATION"); 
end if; 
while (GENERIC PARAMETER DECLARATION) loop 
null; 
end loop; 
if (GENERIC_FORMAL_PART) then 
return( TRUE); 
else 
return (FALSE); 
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end if; 
end GENERIC DECLARATION; 


we ee we em ewe ee oe we we we ee ee ee we ee ee we = = ee = = = = = = = ee =e = = = ow = = = ow = we ee we a se oe eo ee eee 


-- GENERIC_PARAMETER DECLARATION --> IDENTIFIER LIST : [MODE ?] NAME 
oi [:= EXPRESSION ?] ; 
sie --> type private [DISCRIMINANT PART ?] 
re is PRIVATE_TYPE_DECLARATION ; 
=< --> type private [DISCRIMINANT PART ?] 
= is GENERIC_TYPE_ DEFINITION ; 
Se --> with procedure PROCEDURE _UNIT 
-- --> with function FUNCTION_UNIT 
function GENERIC_PARAMETER_ DECLARATION return boolean is 
begin 
if (P4.PRINT CALLS) then 
P4.O0UT_ PUT( "GENERIC PARAMETER DECLARATION"); 
end if; 
if (P2.1IDENTIFIER_LIST) then 
if (7M.MATCH(TM. TOKEN COLON)) then 
if (P2.MODE) then 
null; 
end if; -- if mode statement 
if (P3.NAME) then -- check for type_mark 
if (TM.MATCH( TM. TOKEN _ASSIGNMENT)) then 
if (P3.EXPRESSION) then 


null; 
else 
P4.SYNTAX_ERROR( "Generic parameter declaration"); 
end if; -- if expression statement 
end if; -- if match(token_assignment ) 


if (™M.MATCH(TM.TOKEN SEMICOLON)) then 
return (TRUE); 
else 
P4.SYNTAX_ERROR("Generic parameter declaration"); 
end if; -- if match(token_semicolon) 
else 
P4.SYNTAX_ERROR("Generic parameter declaration"); 
end if; -- if type_mark statement 
else 
P4.SYNTAX_ERROR("Generic parameter declaration"); 
end if; -- if match( token _colon) 
elsif (TM.MATCH(TM.TOKEN _TYPE)) then 
if (TM.MATCH( TM. TOKEN IDENTIFIER)) then 
if (P2.DISCRIMINANT PART) then 
null; 
end if; -- if discriminant part 
if (TM.MATCH(TM.TOKEN IS)) then 
if (P2.PRIVATE TYPE DECLARATION) then 
if (TM.MATCH(TM. TOKEN SEMICOLON)) then 
return (TRUE); 
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else 
P4.SYNTAX_ERROR("Generic parameter declaration"); 
end if; -- if match(token_ semicolon) 
elsif (P2.GENERIC_TYPE_ DEFINITION) then 
if (TM.MATCH(TM. TOKEN SEMICOLON) ) then 
return (TRUE); 


else 
P4.SYNTAX_ERROR("Generic parameter declaration”); 
end if; -- if match(token_semicolon) 
else 
P4.SYNTAX_ERROR( "Generic parameter declaration"); 
end if; -- if private_type_declaration 
else 
P4.SYNTAX_ERROR( "Generic parameter declaration"); 
end if; -- if match(token_is) 
else 
P4.SYNTAX_ERROR(”Generic parameter declaration”); 
end if; -- if match(token_identifier) 


elsif (TM.MATCH(TM. TOKEN WITH)) then 
if (TM.MATCH(TM. TOKEN PROCEDURE)) then 
if (PROCEDURE_UNIT) then 
return (TRUE); 


else 
P4.SYNTAX_ERROR( "Generic parameter declaration"); 
end if; -- if procedure_unit statement 


elsif (TM.MATCH(TM.TOKEN FUNCTION)) then 
if (FUNCTION UNIT) then 
return (TRUE); 


else 
P4.SYNTAX_ERROR("Generic parameter declaration"); 
end if; -- if function_unit statement 
else 
P4.SYNTAX_ERROR( "Generic parameter declaration”); 
end if; -- if match(token_procedure) 
else 
return (FALSE); 
end if; -- if identifier_list 


end GENERIC PARAMETER DECLARATION; 


~~ GENERIC _FORMAL_PART --> procedure PROCEDURE_UNIT 
oe --> function FUNCTION UNIT 
a --> package PACKAGE DECLARATION 
function GENERIC FORMAL PART return boolean is 
begin 
if (P4.PRINT CALLS) then 
P4.QUT PUT( "GENERIC FORMAL PART"); 
end if; 
if (1M.MATCH(TM.TOKEN PROCEDURE )) then 
if (PROCEDURE UNIT) then 
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return (TRUE); 
else 
P4.SYNTAX_ERROR( "Generic formal part"); 
end if; -- if procedure_unit statement 
elsif (TM.MATCH( TM. TOKEN FUNCTION)) then 
if (FUNCTION _UNIT) then 
return (TRUE); 
else 
P4.SYNTAX_ERROR( "Generic formal part"); 
end if; -- if function_unit statement 
elsif (TM.MATCH(TM. TOKEN _PACKAGE)) then 
if (PACKAGE DECLARATION) then 
return (TRUE); 
else 
P4.SYNTAX_ERROR( "Generic formal part"); 
end if; -- if package declaration 
else 
return (FALSE); 
end if; 
end GENERIC FORMAL PART; 


-- PROCEDURE_UNIT --> identifier [FORMAL_PART ?] is SUBPROGRAM_BODY 
=s --> identifier [FORMAL_PART ?] ; 
a --> identifier [FORMAL_PART ?] renames NAME 
function PROCEDURE_UNIT return boolean is 
START TOKEN : TOKEN SCANNER.TOKEN RECORD _TYPE; 
LOCATION : natural; 
begin 
if (P4.PRINT CALLS) then 
P4.QUT_PUT("PROCEDURE_UNIT"); 
end if; 
if (TM.MATCH(TM.TOKEN_IDENTIFIER)) then 
TM.MATCHED TOKEN(START_TOKEN) ; 
CODE_BLOCKER.ENTER CODE_BLOCK(START_TOKEN.SOURCE, "PROCEDURE CODE BLOCK"); 
CODE_BLOCKER.INCREMENT_ STATEMENT COUNT; 
LOCATION := CODE_BLOCKER.CURRENT CODE_BLOCK_NUMBER; 
SYMBOL_TABLE.INSERT_SYM_TAB(START_TOKEN.LEXEME(1..START_TOKEN.LEXEME_ SIZE), 
SYMBOL_ TABLE .PROCEDURE_DECLARATION_TAG, 
LOCATION); 
SYMBOL_TABLE.INSERT_SYM_TAB("END", SYMBOL_TABLE.LABEL_NAME, 0); 
if (IS_MAIN_ PROGRAM) then 
NET GENERATOR.START(SYMBOL_TABLE.FIND KEY(START TOKEN.LEXEME(1.. 
START _TOKEN.LEXEME SIZE))); 


IS_ MAIN PROGRAM := FALSE; 
end if; 
if (P2.FORMAL PART) then 
null; 


end if; -- if formal part statement 
1f (TM.MATCH( TM. TOKEN IS)) then 
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if (SUBPROGRAM BODY) then 
return (TRUE); 
else 
P4.SYNTAX_ERROR( "Procedure unit"); 
end if; -- if subprogram body statement 
elsif (TM.MATCH(TM. TOKEN SEMICOLON)) then 
CODE_BLOCKER.DELETE CODE BLOCK ENTER; 
SYMBOL_TABLE.EXIT SCOPE; 
SYMBOL_TABLE.UPDATE_SYM_TAB(O); 
return (TRUE); 
elsif (TM.MATCH( TM. TOKEN_RENAMES)) then 
CODE_BLOCKER.DELETE CODE _BLOCK_ ENTER; 
SYMBOL_TABLE.EXIT_SCOPE; 
SYMBOL_TABLE.UPDATE_SYM_TAB(0); 
if (P3.NAME) then 
if (TM.MATCH(TM. TOKEN SEMICOLON)) then 
return (TRUE); 


else 
P4.SYNTAX_ERROR( "Procedure unit"); 
end if; -- if match(token_semicolon) 
else 
P4,SYNTAX_ERROR( "Procedure unit"); 
end if; -- if name statement 
end if; -- if match(token_is) 
else 
return (FALSE); 
end if; -- if match(token_identifier) 


end PROCEDURE_UNIT; 


-- SUBPROGRAM_BODY --> mew NAME [GENERIC_ACTUAL_PART ?] ; 
ee --> separate ; 
== 7 eGo 
<2 --> [DECLARATIVE PART ?} [begin SEQUENCE_OF STATEMENTS 
ed [exception [EXCEPTION HANDLER ]+ ?]?] end [DESIGNATOR ?] ; 
ao --> NAME ; 
function SUBPROGRAM_ BODY return boolean is 
START_TOKEN : TOKEN SCANNER. TOKEN RECORD_TYPE; 
STOP_TOKEN : TOKEN_SCANNER.TOKEN_RECORD_TYPE; 
LOCATION _ONE : natural; 
LOCATION_TWO : natural; 
use SYMBOL_TABLE; 
begin 
if (P4.PRINT_CALLS) then 
P4.QUT_PUT("SUBPROGRAM_BODY" ) ; 
end if; 
LOCATION ONE := CODE _BLOCKER.CURRENT CODE BLOCK NUMBER; 
if (1M.MATCH(TM.TOKEN_NEW)) then 
CODE BLOCKER.DELETE CODE BLOCK ENTER; 
SYMBOL TABLE .EXIT_ SCOPE; 
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SYMBOL_TABLE .UPDATE SYM_TAB(0); 
1f (P3.NAME) then 
if (P2.GENERIC_ACTUAL_PART) then 
null; 
end if; -- if generic actual part 
if (TM.MATCH(TM. TOKEN SEMICOLON)) then 
return (TRUE); 


else 
P4,SYNTAX_ERROR( “Subprogram body"); 
end if; -- if match(token_semicolon) 
else 
P4.SYNTAX_ERROR( "Subprogram body"); 
end if; -- if name statement 


elsif (TM.MATCH(TM. TOKEN SEPARATE)) then 
CODE_BLOCKER.DELETE CODE_BLOCK_ENTER; 
SYMBOL_TABLE.EXIT_ SCOPE; 
SYMBOL_TABLE.UPDATE SYM TAB(0); 
if (TM.MATCH(TM.TOKEN SEMICOLON)) then 
return (TRUE); 
else 
P4.SYNTAX_ERROR( “Subprogram body”); 
end if; -- if match(token_semicolon) 
elsif (TM.MATCH(TM. TOKEN BRACKETS)) then 
CODE BLOCKER.DELETE CODE BLOCK_ENTER; 
SYMBOL_TABLE.EXIT_SCOPE; 
SYMBOL_TABLE.UPDATE_SYM_TAB(0); 
if (TM.MATCH(TM.TOKEN SEMICOLON)) then 
return (TRUE); 
else 
P4.SYNTAX_ERROR( "Subprogram body"); 
end if; -- if match(token_semicolon) 
elsif (DECLARATIVE_PART) then 
LOCATION _ONE := CODE_BLOCKER.CURRENT CODE_BLOCK_NUMBER; 
if (TM.MATCH(TM.TOKEN BEGIN)) then 
TM.MATCHED_TOKEN(START_ TOKEN); 
CODE_BLOCKER.ENTER_CODE BLOCK(START_TOKEN.SOURCE, "BEGIN SUBPROGRAM" ) ; 
CODE _BLOCKER.INCREMENT_ STATEMENT COUNT ; 
LOCATION _TWO := CODE_BLOCKER.CURRENT_ CODE BLOCK_NUMBER; 
NET_GENERATOR.CONNECT BLOCKS( LOCATION ONE, LOCATION _TWO); 
if (SEQUENCE OF STATEMENTS) then 
if (CODE _BLOCKER.CURRENT_STATEMENT COUNT = 0) then 
LOCATION_ONE := 0; 
CODE _BLOCKER.DELETE CODE _BLOCK_ENTER; 
else 
TM.MATCHED_TOKEN(STOP_TOKEN) ; 
LOCATION_ONE := CODE _BLOCKER.CURRENT CODE_BLOCK_NUMBER; 
CODE _BLOCKER.EXIT CODE _BLOCK(STOP_TOKEN.SOURCE) ; 
end if; 
1f (TM.MATCH( TM. TOKEN _EXCEPTION)) then 
if (EXCEPTION HANDLER) then 
while (EXCEPTION HANDLER) loop 
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null; 


end loop; 
else 
P4.SYNTAX_ERROR( "Subprogram body”); 
end if; -- if exception_handler statement 
end if; -- if match(token_exception) 
else 
P4.SYNTAX_ERROR( "Subprogram body"); 
end if; -- if sequence of statements 
end if; ~- if token begin 


if (TM.MATCH( TM. TOKEN _ENO)) then 
TM.MATCHEO TOKEN(STOP_TOKEN); 
CODE BLOCKER.ENTER_CODE_BLOCK(STOP_TOKEN.SOURCE, “END SUBPROGRAM" ) ; 
CODE BLOCKER. INCREMENT STATEMENT COUNT; 
LOCATION TWO := COOE_BLOCKER.CURRENT_COOE_BLOCK_NUMBER; 
if (SYMBOL_TABLE.FINO LOCAL_KEY("ENO") = null) then 
raise SYMBOL_TABLE.REFERENCE ERROR; 
else 
SYMBOL_TABLE.UPDATE _SYM_TAB(LOCATION_ TWO); 
end if; 
if (LOCATION _ONE = 0) then 
NET_GENERATOR.EXPLICIT END( LOCATION TWO); 
else 
NET_GENERATOR.CONNECT BLOCKS(LOCATION ONE, LOCATION TWO); 
end if; 
CODE BLOCKER.EXIT_CODE_BLOCK(STOP_TOKEN. SOURCE ); 
if (P2.DESIGNATOR) then 
null; 
end if; -- if designator statement 
if (TM.MATCH( TM. TOKEN SEMICOLON)) then 
CODE _BLOCKER.EXIT CODE BLOCK(STOP_TOKEN.SOURCE) ; 
SYMBOL_TABLE.EXIT_SCOPE; 
return (TRUE); 


else 
P4.SYNTAX_ERROR( "Subprogram body"); 
end if; -- if match(token_semicolon) 
else 
P4.SYNTAX_ERROR( "Subprogram body"); 
end if; -~ if match(token_end) 


elsif (TM.MATCH(TM.TOKEN BEGIN)) then 
TM.MATCHED_TOKEN(START_TOKEN) ; 
LOCATION ONE := CODE _BLOCKER.CURRENT CODE_BLOCK_NUMBER; 
CODE _BLOCKER.ENTER_CODE_BLOCK(START_TOKEN.SOURCE, “BEGIN SUBPROGRAM" ) ; 
LOCATION TWO := CODE _BLOCKER.CURRENT COOE_BLOCK_NUMBER; 
NET_GENERATOR.CONNECT BLOCKS(LOCATION_ONE, LOCATION TWO); 
if (SEQUENCE_OF STATEMENTS) then 
if (CODE BLOCKER.CURRENT STATEMENT COUNT = 0) then 
LOCATION ONE := 0; 
CODE BLOCKER.DELETE CODE BLOCK _ENTER; 
else 
TM.MATCHED TOKEN(STOP_TOKEN) ; 
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LOCATION ONE := CODE_BLOCKER.CURRENT_CODE_BLOCK_NUMBER; 
CODE _BLOCKER.EXIT_CODE_BLOCK(STOP_TOKEN. SOURCE ) ; 
end if; 
if (TM.MATCH(TM.TOKEN_EXCEPTION)) then 
if (EXCEPTION HANDLER) then 
while (EXCEPTION HANDLER) loop 
null; 
end loop; 
else 
P4.SYNTAX_ERROR( "Subprogram body"); 
end if; -- if exception_handler statement 
end if; -- if match(token_exception) 
else 
P4,.SYNTAX_ERROR( "Subprogram body”); 
end if; -- if sequence of statements 
if (TM.MATCH(TM. TOKEN END)) then 
TM.MATCHED_TOKEN( STOP_TOKEN); 
CODE_BLOCKER.ENTER_CODE_BLOCK(STOP_TOKEN.SOURCE, "END SUBPROGRAM" ) ; 
CODE_BLOCKER. INCREMENT STATEMENT COUNT; 
LOCATION_TWO := CODE _BLOCKER.CURRENT_CODE_BLOCK_NUMBER; 
if (SYMBOL_TABLE.FIND_LOCAL_KEY("END") = null) then 
raise SYMBOL_TABLE.REFERENCE_ERROR; 
else 
SYMBOL_TABLE .UPDATE_SYM_TAB(LOCATION_TWO); 
end if; 
if (LOCATION_ONE = 0) then 
NET GENERATOR .EXPLICIT_END(LOCATION TWO); 
else 
NET _GENERATOR.CONNECT BLOCKS(LOCATION ONE, LOCATION_TWO); 
end if; 
CODE_BLOCKER.EXIT_CODE_BLOCK( STOP_TOKEN.SOURCE ); 
if (P2.DESIGNATOR) then 
null; 
end if; -- if designator statement 
if (TM.MATCH( TM. TOKEN SEMICOLON)) then 
CODE_BLOCKER.EXIT_CODE_BLOCK(STOP_TOKEN. SOURCE ); 
SYMBOL_TABLE .EXIT_SCOPE; 
return (TRUE); 


else 
P4.SYNTAX_ERROR( "Subprogram body"); 
end if; -- if match( token_semicolon) 
else 
P4.SYNTAX_ERROR("Subprogram body"); 
end if; -- if match(token_end) 


elsif (TM.MATCH(TM.TOKEN_END)) then 
TM.MATCHED TOKEN(STOP_TOKEN); 
CODE_BLOCKER.ENTER CODE BLOCK(STOP_TOKEN.SOURCE, "END SUBPROGRAM"); 
CODE BLOCKER. INCREMENT STATEMENT COUNT; 
LOCATION TWO := CODE BLOCKER.CURRENT CODE _BLOCK_NUMBER; 
if (SYMBOL _TABLE.FIND_LOCAL_KEY("END") = null) then 
raise SYMBOL_TABLE.REFERENCE ERROR; 
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else 
SYMBOL_TABLE .UPDATE SYM _TAB(LOCATION TWO); 
end if; 
NET GENERATOR.CONNECT BLOCKS(LOCATION_ONE, LOCATION_TWO); 
CODE BLOCKER.EXIT CODE _BLOCK(STOP_TOKEN.SOURCE); 
if (P2.DESTGNATOR) then 
null; 
end if; -- if designator statement 
if (7M.MATCH(TM.TOKEN SEMICOLON)) then 
CODE_BLOCKER.EXIT CODE BLOCK(STOP_TOKEN. SOURCE ) ; 
SYMBOL_TABLE.EXIT_ SCOPE; 
return (TRUE); 
else 
P4.SYNTAX_ERROR( "Subprogram body"); 
end if; -- if match(token_semicolon) 
elsif (P3.NAME) then 
CODE _BLOCKER.DELETE CODE _BLOCK_ENTER; 
SYMBOL_TABLE.EXIT_SCOPE; 
SYMBOL_TABLE.UPDATE SYM _TAB(0); 
if (TM.MATCH( TM. TOKEN SEMICOLON)) then 
return (TRUE); 


else 
P4.SYNTAX_ERROR( "Subprogram body"); 
end if; -- if match(token_semicolon) 
else 
return (FALSE); 
end if; -- if match(token_new) 


end SUBPROGRAM BODY; 


-- FUNCTION_UNIT --> DESIGNATOR [FORMAL_PART ?] return NAME is 
rai SUBPROGRAM_BODY 
oe --> DESIGNATOR [FORMAL_PART ?] return NAME ; 
a --> DESIGNATOR [FORMAL_PART ?] return NAME renames NAME ; 
ae --> DESIGNATOR is SUBPROGRAM BODY 
=a (for generic instantiation) 
function FUNCTION_UNIT return boolean is 
START_TOKEN : TOKEN _SCANNER.TOKEN_ RECORD TYPE; 
LOCATION : natural; 
begin 
if (P4.PRINT_CALLS) then 
P4.QUT_PUT( "FUNCTION UNIT"); 
end if; 
if (P2.DESIGNATOR) then 
TM.MATCHED TOKEN(START_TOKEN); 
CODE _BLOCKER.ENTER_CODE BLOCK(START_TOKEN.SOURCE, “FUNCTION CODE BLOCK"); 
CODE BLOCKER. INCREMENT STATEMENT COUNT; 
LOCATION := CODE BLOCKER.CURRENT_CODE_BLOCK_NUMBER; 
SYMBOL _TABLE.INSERT SYM TAB(START_ TOKEN.LEXEME(1..START TOKEN.LEXEME SIZE), 
SYMBOL _TABLE.FUNCTION DECLARATION TAG, 
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LOCATION); 
SYMBOL_TABLE.INSERT_SYM_TAB( "END", SYMBOL_TABLE.LABEL_NAME, 0); 
if (IS MAIN PROGRAM) then 

NET _GENERATOR.START(SYMBOL_TABLE.FIND_KEY(START TOKEN.LEXEME(1.. 
START_TOKEN.LEXEME SIZE))); 
IS_MAIN_PROGRAM := FALSE; 
end if; 
if (P2.FORMAL_PART) then 
if (TM.MATCH(TM.TOKEN_RETURN)) then 
if (P3.NAME) then 
if (TM.MATCH(TM.TOKEN_IS)) then 
if (SUBPROGRAM BODY) then 
return (TRUE); 
else 
P4.SYNTAX_ERROR( "Function unit"); 
end if; 
elsif (TM.MATCH(TM.TOKEN SEMICOLON)) then 
CODE_BLOCKER.DELETE_CODE BLOCK_ENTER; 
SYMBOL_TABLE .EXIT_SCOPE; 
SYMBOL_TABLE .UPDATE_SYM_TAB(0); 
return (TRUE); 
elsif (T™M.MATCH(TM.TOKEN_RENAMES)) then 
CODE_BLOCKER.DELETE CODE BLOCK_ENTER; 
SYMBOL_TABLE .EXIT_SCOPE ; 
SYMBOL_TABLE .UPDATE_SYM_TAB(Q); 
if (P3.NAME) then 
return (TRUE); 
else 
P4.SYNTAX_ERROR("Function unit”); 
end if; 
else 
P4.SYNTAX_ERROR( "Function unit"); 
end if; 
else 
P4.SYNTAX_ERROR( "Function unit"); 
end if; 
else 
P4.SYNTAX_ERROR( "Function unit”); 
end if; 
elsif (TM.MATCH(TM. TOKEN RETURN)) then 
if (P3.NAME) then 
if (TM.MATCH(TM.TOKEN_IS)) then 
if (SUBPROGRAM BODY) then 
return (TRUE); 
else 
P4.SYNTAX_ERROR( "Function unit"); 
end if; 
elsif (TM.MATCH(TM.TOKEN SEMICOLON) ) then 
CODE BLOCKER.DELETE CODE _BLOCK_ ENTER; 
SYMBOL_TABLE.INSERT SYM TAB("END", SYMBOL_TABLE.LABEL_NAME, 0); 
SYMBOL_TABLE.EXIT_ SCOPE; 
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SYMBOL_TABLE .UPDATE_SYM_TAB(0); 
return (TRUE); 
elsif (TM.MATCH(TM.TOKEN_RENAMES)) then 
CODE BLOCKER.DELETE CODE _BLOCK_ENTER; 
SYMBOL_TABLE.EXIT_SCOPE; 
SYMBOL_TABLE .UPDATE_SYM_TAB(0); 
1f (P3.NAME) then 
return (TRUE); 
else 
P4.SYNTAX_ERROR("“Function unit"); 
end if; 
else 
P4.SYNTAX_ERROR( "Function unit"); 
end if; 
else 
P4.SYNTAX_ERROR( "Function unit”); 
end if; 
else 
P4.SYNTAX_ERROR( “Function unit"); 
end if; 
elsif (TM.MATCH(TM.TOKEN_IS)) then 
if (SUBPROGRAM_BODY) then 
return (TRUE); 
else 
P4.SYNTAX_ERROR("Function unit"); 
end if; 
else 
return (FALSE); 
end if; 
end FUNCTION_UNIT; 


-- TASK_DECLARATION --> body identifier is SUBPROGRAM BODY ; 
== --> [type ?] identifier [is [ENTRY _DECLARATION]* 
ae [REPRESENTATION CLAUSE ]* end [identifier ?] ?] ; 
function TASK DECLARATION return boolean is 
START _TOKEN : TOKEN SCANNER. TOKEN_RECOROD_TYPE; 
LOCATION : natural; 
begin 
if (P4.PRINT_CALLS) then 
P4.D0UT_PUT("TASK_DECLARATION") ; 
end if; 
if (TM.MATCH(TM. TOKEN TYPE)) then 
null; 
end if; -- if match(token_type) 
if (TM.MATCH(TM.TOKEN BODY)) then 
if (TM.MATCH( TM. TOKEN _IDENTIFIER)) then 
TM.MATCHED TOKEN(START_TOKEN) ; 
CODE BLOCKER.ENTER CODE BLOCK(START TOKEN.SOURCE, "TASK CODE BLOCK"); 
CODE BLOCKER. INCREMENT STATEMENT COUNT; 
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LOCATION := CODE_BLOCKER.CURRENT CODE BLOCK_NUMBER; 
SYMBOL_TABLE .INSERT_SYM_TAB(START_TOKEN.LEXEME(1..START_TOKEN. 
LEXEME SIZE), SYMBOL_TABLE.TASK BODY TAG, 
LOCATION) ; 
if. (TM.MATCH( TM. TOKEN_IS)) then 
if (SUBPROGRAM BODY) then 
return (TRUE); 


else 
P4.SYNTAX_ERROR("Package declaration"); 
end if; -- if subprogram body 
else 
P4.SYNTAX_ERROR( "Package declaration”); 
end if; -- if token is 
else 
P4.SYNTAX_ERROR( "Package declaration"); 
end if; -- if token identifier 


elsif (TM.MATCH(TM.TOKEN_IDENTIFIER)) then 
TM.MATCHED TOKEN(START_TOKEN) ; 
SYMBOL_TABLE.INSERT_SYM_TAB(START_TOKEN.LEXEME(1..START_TOKEN. 
LEXEME SIZE), 
SYMBOL_TABLE.TASK_DECLARATION_TAG, 0); 
SYMBOL_TABLE.INSERT_SYM_TAB( "END", SYMBOL_TABLE.LABEL_NAME, 0); 
NET_GENERATOR .START(SYMBOL_TABLE.FIND_KEY(START_TOKEN.LEXEME(1.. 
START_TOKEN.LEXEME SIZE))); 
if (TM.MATCH(TM.TOKEN_IS)) then 
while (P2.ENTRY DECLARATION) loop 
null; 
end loop; 
while (P2.REPRESENTATION CLAUSE) loop 
null; 
end loop; 
if (™.MATCH(TM.TOKEN_END)) then 
if (TM.MATCH(TM.TOKEN IDENTIFIER)) then 
null; 
end if; -- if match(token_identifier) 
if (TM.MATCH( TM. TOKEN SEMICOLON)) then 
SYMBOL_TABLE .EXIT_SCOPE ; 
return (TRUE); 


else 
P4.SYNTAX_ERROR( "Task declaration”); 
end if; -- if match(token_ semicolon) 
else 
P4.SYNTAX_ERROR( "Task declaration"); 
end if; -- if match(token_end) 


elsif (TM.MATCH(TM. TOKEN SEMICOLON)) then 
SYMBOL_TABLE.EXIT_SCOPE; 
return (TRUE); 
else 
P4.SYNTAX_ERROR( "Task declaration” ); 
end if; -- if match(token_is) 
else 
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return (FALSE); 
end if; -- if match(token_body) 
end TASK_DECLARATION; 


-- PACKAGE DECLARATION --> body identifier is SUBPROGRAM_BODY 
i --> identifier is PACKAGE TAIL_END 
== --> identifier renames NAME; 
function PACKAGE DECLARATION return boolean is 
START_TOKEN : TOKEN SCANNER.TOKEN_RECORD_TYPE; 
LOCATION : natural; 
begin 
if (P4.PRINT_CALLS) then 
P4.QUT_PUT( "PACKAGE DECLARATION"); 
end if; 
if (TM.MATCH(TM.TOKEN BODY)) then 
if (TM.MATCH(TM. TOKEN IDENTIFIER)) then 
TM.MATCHED_ TOKEN(START_ TOKEN); 
CODE _BLOCKER.ENTER_CODE_BLOCK(START_TOKEN.SOURCE, "PACKAGE CODE BLOCK"); 
CODE_BLOCKER.INCREMENT_ STATEMENT COUNT; 
LOCATION := CODE_BLOCKER.CURRENT_CODE_BLOCK_NUMBER; 
SYMBOL_TABLE.INSERT_SYM_TAB(START_TOKEN.LEXEME(1..START_TOKEN. 
LEXEME SIZE), SYMBOL_TABLE.PACKAGE BODY_TAG, 
LOCATION); 
if (TM.MATCH(TM.TOKEN_IS)) then 
1f (SUBPROGRAM BODY) then 
return (TRUE); 


else 
P4.SYNTAX_ERROR( "Package declaration"); 
end if; -- if subprogram body 
else 
P4.SYNTAX_ERROR("Package declaration"); 
end if; -- if token is 
else 
P4.SYNTAX_ERROR("Package declaration"); 
end if; -- if token identifier 


elsif (TM.MATCH(TM. TOKEN_IDENTIFIER)) then 
TM.MATCHED TOKEN(START_TOKEN) ; 
if (TM.MATCH(TM.TOKEN_IS)) then 
SYMBOL _TABLE.INSERT_SYM_TAB(START_TOKEN.LEXEME(1..START_TOKEN. 
LEXEME SIZE), 
SYMBOL _TABLE.PACKAGE_DECLARATION_TAG, 0Q); 
SYMBOL _TABLE.INSERT_SYM_TAB("END", SYMBOL_TABLE.LABEL_ NAME, 0); 
if (PACKAGE TAIL_END) then 
return (TRUE); 
else 
P4.SYNTAX_ERROR("Package declaration"); 
end if; -- if package _tail_end 
elsif (TM.MATCH(TM.TOKEN RENAMES)) then 
if (P3.NAME) then 
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1f (TM.MATCH( TM. TOKEN SEMICOLON)) then 
return (TRUE); 


else 
P4.SYNTAX_ERROR("Package declaration"); 
end if; -- if token semicolon 
else 
P4.SYNTAX_ERROR( "Package declaration"); 
end if; -- if name 
else 
P4.SYNTAX_ERROR( "Package declaration"); 
end if; -- if token identifier 
else 
return (FALSE); 
end if; -- if match(token_package) 


end PACKAGE DECLARATION; 
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-- PACKAGE_TAIL_END --> new NAME [GENERIC _ACTUAL_PART ?] ; 
22 --> [BASIC_DECLARATIVE_ITEM]}* (private 
Je [BASIC _DECLARATIVE_ITEM]* ?] end [identifier ?] ; 
function PACKAGE TAIL_END return boolean is 
begin 
if (P4.PRINT_ CALLS) then 
P4.OUT_PUT( "PACKAGE _TAIL_END"); 
end if; 
if (TM.MATCH(TM.TOKEN_NEW)) then 
if (P3.NAME) then 
if (P2.GENERIC_ACTUAL_PART) then 
null; 
end if; -- if generic_actual part statement 
if (TM.MATCH(TM. TOKEN _SEMICOLON)) then 
SYMBOL_TABLE.EXIT_ SCOPE; 
return (TRUE); 


else 
P4.SYNTAX ERROR("Package tail end"); 
end if; -- if match(token_semicolon) 
else 
P4.SYNTAX_ERROR( "Package tail end"); 
end if; -- if name statement 


elsif (BASIC _DECLARATIVE_ITEM) then 
while (BASIC _DECLARATIVE_ITEM) loop 
null; 
end loop; 
if (TM.MATCH( TM. TOKEN _PRIVATE)) then 
while (BASIC _DECLARATIVE_ITEM) loop 
null; 
end loop; 
end if; -- if match( token private) 
if (TM.MATCH(TM.TOKEN END)) then 
1f (TM.MATCH( TM. TOKEN IDENTIFIER)) then 
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null; 

end if; 

if (TM.MATCH(TM. TOKEN SEMICOLON)) then 
SYMBOL_TABLE .EXIT_ SCOPE; 
return (TRUE); 


else 
P4.SYNTAX_ERROR("Package tail end"); 
end if; -- if match(token_semicolon) 
else 
P4,.SYNTAX_ERROR( "Package tail end"); 
end if; -- if match(token_end) 


elsif (TM.MATCH(TM. TOKEN PRIVATE)) then 
while (BASIC DECLARATIVE ITEM) loop 
null; 
end loop; 
if (TM.MATCH(TM.TOKEN_END)) then 
if (TM.MATCH(TM.TOKEN_IDENTIFIER)) then 
null; 
end if; 
if (TM.MATCH(TM.TOKEN SEMICOLON)) then 
SYMBOL_TABLE.EXIT_SCOPE; 
return (TRUE); 


else 
P4.SYNTAX_ERROR( "Package tail end"); 
end if; -- if match(token semicolon) 
else 
P4.SYNTAX_ERROR("Package tail end"); 
end if; -- if match(token_end) 


elsif (TM.MATCH(TM. TOKEN _END)) then 
if (TM.MATCH(TM.TOKEN_IDENTIFIER)) then 
null; 
end if; 
if (TM.MATCH(TM.TOKEN SEMICOLON)) then 
SYMBOL_TABLE .EXIT_SCOPE; 
return (TRUE); 


else 
P4.SYNTAX_ERROR( "Package tail end"); 
end if; -- if match(token_semicolon) 
else 
return (FALSE); 
end if; -- if match(token_new) 


end PACKAGE_TAIL_END; 
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-- BASIC_DECLARATIVE_ITEM --> BASIC_DECLARATIVE 
=< --> REPRESENTATION CLAUSE 
oe --> use WITH _OR_ USE CLAUSE 
function BASIC DECLARATIVE_ITEM return boolean is 
begin 
if (P4.PRINT_ CALLS) then 
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P4.QUT_PUT("BASIC_DECLARATIVE_ITEM"); 
end if; 
if (BASIC_DECLARATION) then 
return (TRUE); 
elsif (P2.REPRESENTATION CLAUSE) then 
return (TRUE); 
elsif (TM.MATCH(TM.TOKEN_USE)) then 
if (P2.WITH_OR_USE CLAUSE) then 
return (TRUE); 
else 
P4.SYNTAX_ERROR( "Basic declarative item”); 
end if; 
else 
return (FALSE); 
end if; 
end BASIC_DECLARATIVE_ITEM; 
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-- DECLARATIVE PART--> [{BASIC_DECLARATIVE_ITEM]* [LATER DECLARATIVE_ITEM]* 
function DECLARATIVE_PART return boolean is 
begin 

if (P4.PRINT_ CALLS) then 

P4.OUT_PUT( "DECLARATIVE PART"); 
end if; 

while (BASIC _DECLARATIVE_ITEM) loop 

null; 

end loop; 

while (LATER _DECLARATIVE_ITEM) loop 

null; 

end loop; 

return (TRUE); 
end DECLARATIVE_PART; 


-- BASIC_DECLARATION --> type TYPE_DECLARATION 
== --> sudtype SUBTYPE_DECLARATION 
eg --> procedure PROCEDURE_UNIT 
=< --> function FUNCTION_UNIT 
ae --> package PACKAGE DECLARATION 
ae -~-> generic GENERIC_DECLARATION 
oe --> IDENTIFIER DECLARATION 
aS --> task TASK_DECLARATION 
function BASIC_DECLARATION return boolean is 
begin 
if (P4.PRINT CALLS) then 
P4.QUT_PUT("BASIC_DECLARATION"); 
end if; 
if (TM.MATCH(TM.TOKEN TYPE)) then 
1f (P2. TYPE DECLARATION) then 
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return (TRUE); 
else 
P4.SYNTAX_ERROR( "Basic declaration"); 
end if; 
elsif (TM.MATCH(TM.TOKEN SUBTYPE)) then 
if (P2.SUBTYPE DECLARATION) then 
return (TRUE); 
else 
P4.SYNTAX_ERROR( "Basic declaration"); 
end if; 
elsif (TM.MATCH(TM. TOKEN PROCEDURE )) then 
if (PROCEDURE_UNIT) then 
return (TRUE); 
else 
P4.SYNTAX_ERROR("“Basic declaration”); 
end if; -- if procedure_unit statement 
elsif (TM.MATCH(TM.TOKEN_FUNCTION)) then 
if (FUNCTION_UNIT) then 
return (TRUE); 
else 
P4.SYNTAX_ERROR( "Basic declaration”); 
end if; -- if function_unit statement 
elsif (TM.MATCH(TM.TOKEN_PACKAGE)) then 
if (PACKAGE DECLARATION) then 
return (TRUE); 
else 
P4.SYNTAX_ERROR( “Basic declaration"); 
end if; -- if package declaration 
elsif (TM.MATCH(TM. TOKEN GENERIC)) then 
if (GENERIC DECLARATION) then 
return (TRUE); 
else 
P4.SYNTAX_ERROR( "Basic declaration”); 
end if; -- if generic_declaration 
elsif (P2. IDENTIFIER DECLARATION) then 
return (TRUE); 
elsif (TM.MATCH(TM.TOKEN_TASK)) then 
if (TASK_DECLARATION) then 
return (TRUE); 
else 
P4.SYNTAX_ERROR( "Basic declaration"); 
end if; 
else 
return (FALSE); 
end if; 
end BASIC_DECLARATION; 


LATER DECLARATIVE ITEM --> PROPER BODY 
= --> generic GENERIC DECLARATION 
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--> use WITH _OR_USE_CLAUSE 


function LATER _DECLARATIVE_ITEM return boolean is 


begin 


if (P4.PRINT CALLS) then 
P4.OUT_PUT("LATER DECLARATIVE ITEM"); 


end if; 


if (PROPER BODY) then 


return (TRUE); 


-- check for body declaration 


elsif (TM.MATCH(TM. TOKEN GENERIC)) then 
if (GENERIC_DECLARATION) then 


return (TRUE); 
else 


P4.SYNTAX_ERROR("“Later declarative item"); 


end if; 


-- if generic_declaration 


elsif (TM.MATCH(TM.TOKEN_USE)) then 
if (P2.WITH_OR_USE_CLAUSE) then 


return (TRUE); 
else 


P4.SYNTAX_ERROR(“Later declarative 


end if; 
else 

return (FALSE); 
end if; 


item"); 
-- if with_or_use clause 


end LATER_DECLARATIVE_ITEM; 


-- PROPER _BODY --> 
sao 
oe 
aD 
function PROPER BODY 
begin 


procedure PROCEDURE_UNIT 
function FUNCTION _UNIT 
package PACKAGE DECLARATION 
task TASK DECLARATION 
return boolean is 


if (P4.PRINT_CALLS) then 
P4.Q0UT_PUT("PROPER BODY"); 


end if; 


if (T™M.MATCH( TM. TOKEN PROCEDURE )) then 
if (PROCEDURE_UNIT) then 


return (TRUE); 
else 


P4.SYNTAX_ERROR("Proper body"); 


end if; 


-- if procedure _unit statement 


elsif (TM.MATCH(TM. TOKEN FUNCTION)) then 
if (FUNCTION UNIT) then 


return (TRUE); 
else 


P4.SYNTAX ERROR("Proper body"); 


end if; 


-- if function_unit statement 


elsif (TM.MATCH(TM. TOKEN PACKAGE)) then 
if (PACKAGE DECLARATION) then 


return (TRUE); 
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else 
P4.SYNTAX_ERROR("Proper body"); 
end if; -- if package declaration 
elsif (TM.MATCH(TM.TOKEN_TASK)) then 
if (TASK_DECLARATION) then 
return (TRUE); 
else 
P4.SYNTAX_ERROR( "Proper body"); 
end if; 
else 
return (FALSE); 
end if; -- if match(token_procedure) 
end PROPER BODY; 


~- SEQUENCE _OF_ STATEMENTS --> [STATEMENT ]+ 
function SEQUENCE OF STATEMENTS return boolean is 
begin 
if (P4.PRINT_CALLS) then 
P4.OUT_PUT( "SEQUENCE OF STATEMENTS"); 
end if; 
if (STATEMENT) then 
while (STATEMENT) loop 
null; 
end loop; 
return (TRUE); 
else 
return (FALSE); 
end if; 
end SEQUENCE OF STATEMENTS; 


-- STATEMENT --> [LABEL ?] SIMPLE STATEMENT 
== --> [LABEL ?] COMPOUND STATEMENT 
function STATEMENT return boolean is 
begin 
if (P4.PRINT CALLS) then 
P4.OUT_PUT("STATEMENT"); 
end if; 
if (P2.LABEL) then 
null; 
end if; 
if (P2.SIMPLE STATEMENT) then 
return (TRUE); 
elsif (COMPOUND STATEMENT) then 
return (TRUE); 
else 
return (FALSE); 
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end if; 
end STATEMENT; 


-- COMPOUND STATEMENT --> if IF_STATEMENT 
<a --> case CASE_STATEMENT 
SS --> LOOP_STATEMENT 
-- --> BLOCK _STATEMENT 
oe --> accept ACCEPT_STATEMENT 
oe --> SELECT_STATEMENT 
function COMPOUND_STATEMENT return boolean is 
START_TOKEN : TOKEN_SCANNER.TOKEN_RECORD_TYPE; 
LOCATION_ONE : positive; 
LOCATION_TWO : positive; 
use SYMBOL_TABLE; 
begin 
if (P4.PRINT_CALLS) then 
P4.QUT_PUT( "COMPOUND_STATEMENT”); 
end if; 
if (TM.MATCH(TM.TOKEN_IF)) then 
if (IF_STATEMENT) then 
CODE_BLOCKER.INCREMENT_STATEMENT_ COUNT; 
return (TRUE); 
else 
P4.SYNTAX_ERROR( "Compound statement”); 
end if; -- if if_statement 
elsif (TM.MATCH(TM.TOKEN CASE)) then 
if (CASE_STATEMENT) then 
CODE_BLOCKER. INCREMENT STATEMENT COUNT; 
return (TRUE); 
else 
P4.SYNTAX_ERROR( "Compound statement”); 
end if; -- if case statement 
elsif (LOOP_STATEMENT) then 
return (TRUE); 
elsif (BLOCK STATEMENT) then 
CODE_BLOCKER.INCREMENT STATEMENT COUNT; 
return (TRUE); 
elsif (TM.MATCH(TM. TOKEN ACCEPT)) then 
if (ACCEPT STATEMENT) then 
return (TRUE); 
else 
P4.SYNTAX_ERROR( "Compound statement"); 
end if; -- if accept _statement 
elsif (SELECT_STATEMENT) then 
return (TRUE); 
else 
return (FALSE); 
end if; 
end COMPOUND STATEMENT; 
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-- BLOCK STATEMENT --> [declare DECLARATIVE PART ?] 
Se begin SEQUENCE OF STATEMENTS [exception 
ae [EXCEPTION HANOLER]+ ?] ?} end [identifier ?]} ; 
function BLOCK_STATEMENT return boolean is 
begin 
if (P4.PRINT CALLS) then 
P4.OUT_PUT("BLOCK_STATEMENT"); 
end if; 
if (T™M.MATCH(TM.TOKEN DECLARE)) then 
if (DECLARATIVE PART) then 


null; 
else 
P4.SYNTAX_ERROR( "Block statement”); 
end if; -- if declarative part statement 
end if; -- if match(token_declare) 


if (TM.MATCH(TM. TOKEN BEGIN)) then 
if (SEQUENCE_OF STATEMENTS) then 
if (TM.MATCH(TM. TOKEN EXCEPTION)) then 
if (EXCEPTION _HANOLER) then 
while (EXCEPTION _HANOLER) loop 


null; 
end loop; 
else 
P4.SYNTAX_ERROR( "Block statement”); 
end if; -- if exception_handler statement 
end if; -- if match( token_exception) 


if (TM.MATCH( TM. TOKEN _ENOD)) then 
if (TM.MATCH(TM.TOKEN_IDENTIFIER)) then 
null; 
end if; -- if match(token_identif ier) 
if (™.MATCH( TM. TOKEN _SEMICOLON)) then 
return (TRUE); 


else 
P4.SYNTAX_ERROR("Block statement"); 
end if; -- if match(token_semicolon) 
else 
P4.SYNTAX_ERROR("Block statement"); 
end if; -- if match(token_end) 
else 
P4.SYNTAX_ERROR( "Block statement"); 
end if; -- if sequence _of_statements 
else 
return (FALSE); 
end if; -- if match(token_begin) 


end BLOCK STATEMENT; 
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-- IF_STATEMENT --> EXPRESSION then SEQUENCE OF STATEMENTS 
a [elsif EXPRESSION then SEQUENCE_OF STATEMENTS ]* 
== [else SEQUENCE _OF STATEMENTS ?] end if ; 
function IF _ STATEMENT return boolean is 
begin 
if (P4.PRINT_CALLS) then 
P4.OUT_PUT("IF_STATEMENT") ; 
end if; 
if (P3.EXPRESSION) then 
if (TM.MATCH(TM.TOKEN_THEN)) then 
if (SEQUENCE_OF_STATEMENTS) then 
while (TM.MATCH(TM. TOKEN ELSIF)) loop 
if (P3.EXPRESSION) then 
if (TM.MATCH(TM.TOKEN THEN)) then 
if not (SEQUENCE _OF STATEMENTS) then 
P4.SYNTAX_ERROR("If statement"); 


end if; -- if not sequence _of_statements 
else 
P4.SYNTAX_ERROR( "If statement"); 
end if; -- if match(token_then) 
else 
P4.SYNTAX_ERROR( "If statement"); 
end if; -- if expression statement 
end loop; 


if (TM.MATCH(TM. TOKEN ELSE)) then 
if (SEQUENCE_OF STATEMENTS) then 


null; 
else 
P4.SYNTAX_ERROR("If statement"); 
end if; -- if sequence_of_statements 
end if; -- if match(token_else) 


if (TM.MATCH(TM.TOKEN_END)) then 
if (TM.MATCH(TM.TOKEN_IF)) then 
if (™M.MATCH(TM.TOKEN SEMICOLON)) then 
return (TRUE); 


else 
P4.SYNTAX_ERROR( "If statement"); 
end if; -- if match(token_semicolon) 
else 
P4.SYNTAX_ERROR("If statement”); 
end if; -- if match(token_if ) 
else 
P4.SYNTAX_ERROR( "If statement"); 
end if; -- if match(token_end) 
else 
P4.SYNTAX_ERROR("If statement"); 
end if; -- if sequence _of_statements 
else 
P4.SYNTAX_ERROR("If statement"); 
end if; -- if match( token then) 
else 
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return (FALSE); 
end if; -- if expression statement 
end IF_STATEMENT; 


-- CASE STATEMENT --> EXPRESSION is [CASE STATEMENT ALTERNATIVE ]+ end case ; 
function CASE STATEMENT return boolean is 
begin 
if (P4.PRINT CALLS) then 
P4.0UT_PUT("CASE_STATEMENT"); 
end if; 
if (P3.EXPRESSION) then 
if (TM.MATCH(TM.TOKEN_IS)) then 
if (CASE_STATEMENT ALTERNATIVE) then 
while (CASE STATEMENT ALTERNATIVE) loop 
null; 
end loop; 
if (TM.MATCH(TM.TOKEN_END)) then 
if (TM.MATCH(TM.TOKEN_CASE)) then 
if (TM.MATCH(TM. TOKEN SEMICOLON)) then 
return (TRUE); 


else 
P4.SYNTAX_ERROR( “Case statement"); 
end if; -- if match( token_semicolon) 
else 
P4.SYNTAX_ERROR("Case statement"); 
end if; -- if match(token_case) 
else 
P4.SYNTAX_ERROR("Case statement"); 
end if; -- if match(token_end) 
else 
P4.SYNTAX_ERROR("Case statement"); 
end if; => it case_statement_alternative 
else 
P4.SYNTAX_ERROR("Case statement"); 
end if; -- if match(token_is) 
else 
return (FALSE); 
end if; -- if expression statement 


end CASE_STATEMENT; 


-- CASE STATEMENT ALTERNATIVE --> when CHOICE [| CHOICE]* => 
a SEQUENCE_OF_ STATEMENTS 
function CASE STATEMENT ALTERNATIVE return boolean is 
begin 
if (P4.PRINT_ CALLS) then 
P4.QUT_PUT( "CASE STATEMENT ALTERNATIVE"), 
end if; 
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if (TM.MATCH(TM. TOKEN WHEN)) then 
moecPs.CHOICE) then 
while (TM.MATCH(TM. TOKEN _BAR)) loop 
if not (P3.CHOICE) then 
P4.SYNTAX_ERROR("Case statement alternative"); 
end if; -- if not choice statement 
end loop; 
if (TM.MATCH(TM. TOKEN ARROW)) then 
if (SEQUENCE _OF_STATEMENTS) then 
return (TRUE); 


else 
P4.SYNTAX_ERROR(“Case statement alternative"); 
end if; -- if sequence _of_statements 
else 
P4.SYNTAX_ERROR("Case statement alternative"); 
end if; -- if match(token_arrow) 
else 
P4.SYNTAX_ERROR("“Case statement alternative"); 
end if; -- if choice statement 
else 
return (FALSE); 
end if; ~- if match( token_when) 


end CASE_STATEMENT ALTERNATIVE; 


ee LOOP_STATEMENT --> [ITERATION SCHEME ?] loop 
a SEQUENCE_OF_STATEMENTS end loop [identifier ?] ; 
function LOOP_STATEMENT return boolean is 
STOP_TOKEN : TOKEN_SCANNER.TOKEN_RECORD_TYPE; 
LOCATION_ONE : natural; 
LOCATION_TWO : positive; 
use SYMBOL_TABLE; 
begin 
if (P4.PRINT_CALLS) then 
P4.OUT_PUT("LOOP_STATEMENT"); 
end if; 
if (P3. ITERATION SCHEME) then 
null; 
end if; -~- if iteration_scheme statement 
if (TM.MATCH(TM.TOKEN_LOOP)) then 
TM.MATCHED_TOKEN(STOP_TOKEN); 
if (CODE_BLOCKER.CURRENT STATEMENT COUNT /= 0) then 
LOCATION ONE := CODE _BLOCKER.CURRENT CODE BLOCK NUMBER; 
CODE_BLOCKER.EXIT_CODE_BLOCK(STOP_TOKEN.SOURCE) ; 
CODE _BLOCKER.ENTER CODE _BLOCK(STOP_TOKEN.SOURCE, "LOOP BLOCK"); 
LOCATION TWO := CODE BLOCKER.CURRENT CODE BLOCK NUMBER; 
CODE_BLOCKER. INCREMENT_STATEMENT COUNT; 
NET _GENERATOR.CONNECT BLOCKS(LOCATION_ONE, LOCATION_TWO); 
SYMBOL _TABLE.INSERT SYM TAB("LOOP", LOOP_TAG, LOCATION TWO); 
SYMBOL _TABLE.INSERT SYM TAB("END", LABEL_NAME, 0); 
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else 
CODE _BLOCKER.DELETE CODE BLOCK ENTER; 
CODE_BLOCKER.ENTER_CODE_ BLOCK(STOP_TOKEN.SOURCE, "LOOP BLOCK"); 
CODE _BLOCKER.INCREMENT STATEMENT COUNT; 
LOCATION _TWO := CODE BLOCKER.CURRENT CODE BLOCK NUMBER; 
SYMBOL_TABLE.INSERT SYM_TAB("LOOP”, LOOP_TAG, LOCATION TWO); 
SYMBOL_TABLE.INSERT_SYM_TAB( "END", LABEL_NAME, 0); 
end if; 
if (SEQUENCE_OF_ STATEMENTS) then 
if (CODE_BLOCKER.CURRENT STATEMENT COUNT = 0) then 
LOCATION ONE := 0; 
CODE_BLOCKER.DELETE CODE BLOCK_ENTER; 
else 
TM.MATCHED_TOKEN(STOP_TOKEN) ; 
LOCATION _ONE := CODE_BLOCKER.CURRENT_CODE_ BLOCK_NUMBER; 
CODE _BLOCKER.EXIT_CODE_ BLOCK(STOP_TOKEN.SOURCE) ; 
end if; 
if (TM.MATCH(TM.TOKEN_END)) then 
if (TM.MATCH(TM. TOKEN LOOP)) then 
TM.MATCHED_TOKEN( STOP_TOKEN) ; 
CODE _BLOCKER.ENTER CODE _BLOCK(STOP_TOKEN.SOURCE, “END LOOP”); 
CODE_BLOCKER.INCREMENT STATEMENT COUNT; 
LOCATION TWO := CODE _BLOCKER.CURRENT CODE BLOCK NUMBER; 
if (SYMBOL_TABLE.FIND _LOCAL_KEY("END") = null) then 
raise SYMBOL_TABLE.REFERENCE_ERROR; 
else 
SYMBOL_TABLE.UPDATE_SYM_TAB(LOCATION_ TWO) ; 
end if; 
if (LOCATION ONE = 0) then 
NET GENERATOR. EXPLICIT END( LOCATION TWO); 
else 
NET_GENERATOR.CONNECT BLOCKS(LOCATION_ONE, LOCATION _TWO); 
end if; 
CODE BLOCKER .EXIT_CODE BLOCK(STOP_TOKEN.SOURCE) ; 
CODE_BLOCKER. ENTER CODE _BLOCK(STOP_TOKEN.SOURCE, ""); 
if (T.MATCH(TM.TOKEN_IDENTIFIER)) then 
null; 
end if; -- if match(token_identifier) 
if (TM.MATCH(TM.TOKEN SEMICOLON)) then 
SYMBOL_TABLE.EXIT SCOPE; 
NET_GENERATOR.END_LOOP(LOCATION_TWO, SYMBOL_TABLE.RETRIEVE_SYM); 
return (TRUE); 


else 
P4.SYNTAX_ERROR( "Loop statement: expecting semicolon"); 
end if; -- if match(token_semicolon) 
else 
P4.SYNTAX_ERROR( "Loop statement: end must be fully bracketed"); 
end if; -- if match(token_loop) 
else 
P4.SYNTAX ERROR( "Loop statement: expecting ‘end'"); 
end if; -- if match(token_ end) 
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else 
P4.SYNTAX_ERROR( "Loop statement: expecting sequence of statements"); 


end if; -- if sequence of_statements 
else 

return (FALSE); 
end if; -- if match(token_loop) 


end LOOP_STATEMENT ; 


-- EXCEPTION_HANDLER --> when EXCEPTION CHOICE [| EXCEPTION_CHOICE]* => 
== SEQUENCE_OF_STATEMENTS 
function EXCEPTION _HANDLER return boolean is 
begin 
if (P4.PRINT_CALLS) then 
P4.OUT_PUT("EXCEPTION_ HANDLER"); 
end if; 
if (7M.MATCH(TM.TOKEN WHEN)) then 
if (P2.EXCEPTION CHOICE) then 
while (TM.MATCH( TM. TOKEN BAR)) loop 
if not (P2.EXCEPTION CHOICE) then 
P4.SYNTAX_ERROR( "Exception handler”); 
end if; -- if not exception_choice 
end loop; 
if (TM.MATCH(TM.TOKEN_ARROW)) then 
if (SEQUENCE_OF STATEMENTS) then 
return (TRUE); 


else 
P4.SYNTAX_ERROR( "Exception handler”); 
end if; -- if sequence_of_statements 
else 
P4.SYNTAX_ERROR( "Exception handler"); 
end if; -- if match(token_arrow) 
else 
P4.SYNTAX_ERROR( "Exception handler"); 
end if; -- if exception_choice statement 
else 
return (FALSE); 
end if; -- if match( token-when) 


end EXCEPTION_HANDLER; 


-- ACCEPT STATEMENT --> identifier [(EXPRESSION) ?] [FORMAL_PART 7] 
-- [do SEQUENCE_OF_STATEMENTS end [identifier ?] ?] ; 
function ACCEPT STATEMENT return boolean is 
STOP_TOKEN : TOKEN SCANNER.TOKEN RECORD_TYPE; 
LOCATION_ONE : natural; 
LOCATION_TWO : positive; 
use SYMBOL_TABLE; 
begin 
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if (P4.PRINT_CALLS) then 
P4.QUT_PUT( "ACCEPT STATEMENT”), 
end if; 
if (TM.MATCH( TM. TOKEN _IDENTIFIER)) then 
TM.MATCHED_ TOKEN( STOP_TOKEN); 
if (CODE BLOCKER.CURRENT STATEMENT COUNT /= 0) then 
CODE _BLOCKER.INCREMENT STATEMENT COUNT; 
LOCATION_ONE := CODE _BLOCKER.CURRENT CODE_BLOCK_NUMBER, 
else 
CODE_BLOCKER.DELETE CODE _BLOCK_ENTER; 
CODE_BLOCKER.ENTER_CODE_BLOCK(STOP_TOKEN.SOURCE, "ACCEPT STATEMENT”); 
CODE BLOCKER. INCREMENT STATEMENT COUNT; 
LOCATION_ONE := CODE BLOCKER.CURRENT CODE_BLOCK_NUMBER; 
end if; 
CODE_BLOCKER.ENTER_CODE_BLOCK(STOP_TOKEN.SOURCE, "ENTRY BLOCK"); 
LOCATION TWO := CODE BLOCKER.CURRENT CODE _BLOCK_NUMBER; 
CODE_BLOCKER. INCREMENT STATEMENT COUNT; 
NET GENERATOR. TASK _ACCEPT(LOCATION ONE, LOCATION_TWO) ; 
SYMBOL_TABLE.INSERT_SYM_TAB( STOP_TOKEN.LEXEME(1..STOP_TOKEN. 
LEXEME SIZE), SYMBOL_TABLE.ACCEPT TAG, 
LOCATION_TWO); 
CODE_BLOCKER.EXIT_CODE_BLOCK(STOP_TOKEN. SOURCE ); 
if (TM.MATCH( TM. TOKEN _LEFT_PAREN)) then 
if (P3.EXPRESSION) then 
if (TM.MATCH(TM. TOKEN RIGHT _PAREN)) then 
null; 
else 
P4.SYNTAX_ERROR( "Accept statement"); 
end if; -- if match(token_right_paren) 
else 
P4.SYNTAX_ERROR( "Accept statement"); 
end if; -- if expression statement 
end if; -- if match(token_left_paren) 
if (P2.FORMAL_PART) then 
null; 
end if; -- if formal_part statement 
if (TM.MATCH(TM. TOKEN _DO)) then 
TM.MATCHED_TOKEN(STOP_TOKEN); 
CODE BLOCKER.EXIT_CODE_BLOCK(STOP_TOKEN. SOURCE ); 
CODE_BLOCKER.ENTER CODE BLOCK(STOP_TOKEN.SOURCE, 
"BEGIN ACCEPT STATEMENTS"); 
CODE_BLOCKER. INCREMENT STATEMENT COUNT; 
if (SEQUENCE OF STATEMENTS) then 
if (CODE _BLOCKER.CURRENT_ STATEMENT COUNT = 0) then 
LOCATION _ONE := 0; 
CODE _BLOCKER.DELETE CODE BLOCK_ENTER; 
else 
TM.MATCHED_TOKEN(STOP_TOKEN); 
LOCATION ONE := CODE BLOCKER.CURRENT CODE BLOCK NUMBER; 
CODE BLOCKER.EXIT CODE BLOCK(STOP_TOKEN. SOURCE); 
end if; 
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if (TM.MATCH(TM.TOKEN_END)) then 
TM.MATCHED_TOKEN(STOP_TOKEN) ; 
CODE _BLOCKER.ENTER_CODE BLOCK(STOP_TOKEN.SOURCE, "END ENTRY BLOCK"); 
CODE BLOCKER. INCREMENT STATEMENT COUNT; 
LOCATION_TWO := CODE_BLOCKER.CURRENT_CODE_BLOCK_NUMBER; 
if (SYMBOL_TABLE.FIND_LOCAL_KEY("END") = null) then 
raise SYMBOL_TABLE.REFERENCE_ ERROR; 
else 
SYMBOL_TABLE.UPDATE_SYM_TAB( LOCATION TWO); 
end if; 
if (LOCATION ONE = 0) then 
NET_GENERATOR.EXPLICIT_END_ACCEPT(LOCATION_TWO) ; 
else 
NET_GENERATOR.END_ACCEPT(LOCATION_ONE, LOCATION_TWO); 
end if; 
CODE_BLOCKER.EXIT_CODE_BLOCK(STOP_TOKEN.SOURCE ); 
CODE _BLOCKER.ENTER_CODE BLOCK(STOP_TOKEN.SOURCE, ""); 
if (TM.MATCH(TM.TOKEN IDENTIFIER)) then 


null; 
end if; -- if match(token_identifier) 
else 
P4.SYNTAX_ERROR( "Accept statement"); 
end if; -- if match(token_end) 
else 
P4.SYNTAX_ERROR( "Accept statement"); 
end if; -- if sequence _of_statements 
end if; -- if match(token_ do) 


if (TM.MATCH(TM. TOKEN SEMICOLON)) then 
SYMBOL_TABLE .EXIT_SCOPE; 
return (TRUE); 


else 
P4.SYNTAX_ERROR( "Accept statement"); 
end if; -- if match({token_semicolon) 
else 
return (FALSE); 
end if; -- if match(token_identifier) 


end ACCEPT_STATEMENT; 


-- SELECT_STATEMENT --> select SELECT STATEMENT TAIL [ SELECT_ENTRY_CALL ?] 
== end select ; 
function SELECT _STATEMENT return boolean is 
STOP_TOKEN : TOKEN SCANNER.TOKEN RECORD _TYPE; 
LOCATION ONE : positive; 
LOCATION TWO : positive; 
use SYMBOL_TABLE; 
begin 
if (P4.PRINT_CALLS) then 
P4.0UT PUT( "SELECT STATEMENT"); 
end if; 
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if (TM.MATCH(TM. TOKEN SELECT)) then 
TM.MATCHED_TOKEN(STOP_TOKEN) ; 
if (CODE _BLOCKER.CURRENT_ STATEMENT _CDUNT /= 0) then 
LOCATION_ONE := CODE_BLOCKER.CURRENT CODE BLOCK NUMBER; 
COOE_BLOCKER.EXIT_COOE_BLOCK(STOP_TOKEN.SOURCE ); 
CODE _BLOCKER.ENTER COOE BLOCK(STOP_TOKEN.SOURCE, "SELECT BLOCK"); 
CODE BLOCKER. INCREMENT STATEMENT COUNT; 
LOCATION _TWO := CODE_BLOCKER.CURRENT COOE BLOCK_NUMBER; 
NET_GENERATOR.CONNECT BLOCKS(LOCATION_ONE, LOCATION_TWO); 
else 
CODE_BLOCKER.OELETE CODE_BLOCK_ENTER; 
CODE_BLOCKER.ENTER_COOE_BLOCK(STOP_TOKEN.SOURCE, “SELECT BLOCK"); 
COOE BLOCKER. INCREMENT STATEMENT COUNT; 
LOCATION TWO := CODE_BLOCKER.CURRENT CODE_BLOCK_NUMBER; 
end if; 
SYMBOL_TABLE.INSERT_SYM_TAB("SELECT", SELECT TAG, LOCATION_TWO); 
SYMBOL_TABLE.INSERT_SYM_TAB( "END", LABEL_NAME, 0); 
NET GENERATOR .DECISION_START(LOCATION_TWO, SYMBOL_TABLE.RETRIEVE SYM); 
if (SELECT STATEMENT TAIL) then 
if (SELECT_ENTRY_CALL) then 
if (TM.MATCH(TM.TOKEN_END)) then 
if (TM.MATCH(TM. TOKEN SELECT)) then 
if (T™.MATCH(TM.TOKEN_SEMICOLON)) then 
TM.MATCHEO TOKEN( STOP_TOKEN); 
if (CODE_BLOCKER.CURRENT STATEMENT COUNT /= 0) then 
LOCATION_ONE := COOE_BLOCKER.CURRENT_ COOE_BLOCK_NUMBER; 
COOE_BLOCKER.EXIT COOE_BLOCK(STOP_TOKEN.SOURCE ); 
NET _GENERATOR.END DECISION(LOCATION ONE); 
else 
CODE _BLOCKER.DELETE CODE_BLOCK_ENTER; 
NET GENERATOR .EXPLICIT_END DECISION; 
end if; 
COOE_ BLOCKER.ENTER CODE BLOCK(STOP_TOKEN.SOURCE, "END SELECT"); 
COOE_ BLOCKER. INCREMENT STATEMENT COUNT; 
LOCATION ONE := CODE _BLOCKER.CURRENT COOE_ BLOCK NUMBER; 
if (SYMBOL_TABLE.FIND_LOCAL_KEY("END") = null) then 
raise SYMBOL_TABLE.REFERENCE_ ERROR; 
else 
SYMBOL_TABLE .UPDATE_SYM_ TAB(LOCATION ONE); 
end if; 
CODE BLDCKER.EXIT_ CODE BLOCK(STOP_TOKEN.SOURCE ); 
CODE BLOCKER.ENTER CODE _BLOCK(STOP_TOKEN.SOURCE, ""); 
SYMBOL_TABLE .EXIT_SCOPE; 
return (TRUE); 


else 
P4.SYNTAX_ERROR("Select statement"); 
end if; -- if match(token_semicolon) 
else 
P4.SYNTAX_ERROR( "Select statement"); 
end if; -- if match(token select) 
else 
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P4.SYNTAX_ERROR("Select statement"); 
end if; -- if match(token_end) 
elsif (TM.MATCH(TM. TOKEN _END)) then 
if (TM.MATCH( TM. TOKEN SELECT)) then 
if (TM.MATCH(TM. TOKEN _SEMICOLON)) then 

TM.MATCHED_ TOKEN(STOP_TOKEN) ; 

if (CODE _BLOCKER.CURRENT_STATEMENT COUNT /= 0) then 
LOCATION_ONE := CODE_BLOCKER.CURRENT_ CODE BLOCK_NUMBER; 
CODE_BLOCKER.EXIT_CODE_BLOCK(STOP_TOKEN. SOURCE); 
NET GENERATOR.END DECISION(LOCATION ONE); 

else 
CODE_BLOCKER.DELETE_CODE_BLOCK_ENTER; 
NET _GENERATOR.EXPLICIT_END DECISION; 

end if; 

CODE_BLOCKER. ENTER CODE _BLOCK( STOP_TOKEN.SOURCE, "END SELECT"); 

CODE BLOCKER. INCREMENT STATEMENT COUNT; 

LOCATION_ONE := CODE _BLOCKER.CURRENT_CODE_BLOCK_ NUMBER; 

if (SYMBOL_TABLE.FIND_LOCAL_KEY("END") = null) then 
raise SYMBOL_TABLE.REFERENCE ERROR; 

else 
SYMBOL_TABLE .UPDATE_SYM_TAB( LOCATION _ONE); 

end if; 

CODE_BLOCKER.EXIT_CODE_BLOCK( STOP_TOKEN.SOURCE ) ; 

CODE _BLOCKER.ENTER_CODE_BLOCK(STOP_TOKEN.SOURCE, ""); 

SYMBOL_TABLE .EXIT_SCOPE; 

return (TRUE); 


else 
P4.SYNTAX_ERROR( "Select statement"); 
end if; -- if match({token_semicolon) 
else 
P4.SYNTAX_ERROR("Select statement"); 
end if; -- if match(token_select) 
else 
P4.SYNTAX_ERROR( "Select statement"); 
end if; -- if match({token_end) 
else 
P4.SYNTAX_ERROR("Select statement”); 
end if; -- if select _statement_tail 
else 
return (FALSE); 
end if; 


end SELECT _STATEMENT; 


-- SELECT STATEMENT TAIL --> SELECT ALTERNATIVE [or SELECT ALTERNATIVE ]* 
= --> NAME ; [SEQUENCE OF STATEMENTS ?] 

function SELECT STATEMENT TAIL return boolean is 

STOP_TOKEN : TOKEN SCANNER. TOKEN RECORD_TYPE; 

LOCATION ONE : positive; 

SEARCH POINTER : SYMBOL TABLE.SYM TAB ACCESS; 
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use SYMBOL_TABLE; 
begin 
if (P4.PRINT_CALLS) then 
P4.OUT_PUT("SELECT STATEMENT TAIL"); 
end if; 
if (SELECT_ALTERNATIVE) then 
while (TM.MATCH(TM. TOKEN _OR)) loop 
TM.MATCHED_TOKEN(STOP_TOKEN); 
if (CODE_BLOCKER.CURRENT_STATEMENT COUNT /= 0) then 
LOCATION_ONE := CODE_BLOCKER.CURRENT_CODE_BLOCK_NUMBER; 
CODE _BLOCKER.EXIT_CODE_BLOCK(STOP_TOKEN. SOURCE ); 
NET_GENERATOR .DECISION_OR(LOCATION ONE); 
else 
CODE BLOCKER.DELETE CODE BLOCK_ENTER; 
NET_GENERATOR.EXPLICIT_DECISION_OR; 
end if; 
if not (SELECT_ALTERNATIVE) then 
P4.SYNTAX_ERROR("Select statement tail"); 
end if; 
end loop; 
return (TRUE); 
else 
SYMBOL_TABLE.SAVE_CURRENT_ENTRY; 
if (P3.NAME) then -- check for entry call statement 
TM.MATCHED_TOKEN(STOP_TOKEN); 
SEARCH POINTER := SYMBOL_TABLE.RETRIEVE_SYM; 
if ((SEARCH_POINTER /= null) and then 
(SEARCH _POINTER.TAG_TYPE = SYMBOL_TABLE.ENTRY_TAG)) then 
LOCATION _ONE := CODE BLOCKER.CURRENT CODE _BLOCK_NUMBER; 
CODE BLOCKER. INCREMENT STATEMENT COUNT; 
CODE_BLOCKER.EXIT_CODE_ BLOCK(STOP_TOKEN. SOURCE) ; 
NET_GENERATOR.ENTRY_CALL(LOCATION_ONE, SEARCH POINTER); 
CODE _BLOCKER.ENTER_CODE_BLOCK(STOP_TOKEN.SOURCE, ""); 
SYMBOL_TABLE.RESTORE_CURRENT_ ENTRY; 
else 
SYMBOL_TABLE .RESTORE_CURRENT_ENTRY; 
return (FALSE); 
end if; 
if (7M.MATCH(TM. TOKEN SEMICOLON) ) then 
if (SEQUENCE_OF STATEMENTS) then 
null; 
end if; -- if sequence_of_statements 
return (TRUE); 
else 
P4.SYNTAX_ERROR("Select statement tail"); 
end if; -- if match( token _semicolon) 
else 
return (FALSE); 
end if; 
end if; -- if select alternative statement 
end SELECT STATEMENT TAIL; 
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-- SELECT ALTERNATIVE --> [when EXPRESSION => ?] accept ACCEPT STATEMENT 
ae [SEQUENCE _OF_STATEMENTS ?} 
-- --> [when EXPRESSION => ?] delay DELAY_STATEMENT 
== [SEQUENCE OF STATEMENTS ?} 
~- --> [when EXPRESSION => ?] terminate ; 
function SELECT_ALTERNATIVE return boolean is 
begin 
if (P4.PRINT_CALLS) then 
P4.Q0UT_PUT( "SELECT ALTERNATIVE"); 
end if; 
if (TM.MATCH(TM. TOKEN WHEN)) then 
if (P3.EXPRESSION) then 
if (17M.MATCH(TM. TOKEN_ARROW)) then 


null; 
else 
P4.SYNTAX_ERROR("Select alternative"); 
end if; -- if match(token_arrow) 
else 
P4.SYNTAX_ERROR( "Select alternative"); 
end if; -- if expression statement 
end if; -- if match(token_when) 


if (TM.MATCH( TM. TOKEN ACCEPT)) then 
if (ACCEPT_STATEMENT) then 
if (SEQUENCE_OF_ STATEMENTS) then 


null; 
end if; -- if sequence of statements 
return (TRUE); 
else 
P4.SYNTAX_ERROR( "Select alternative"); 
end if; -- if accept_statement 


elsif (TM.MATCH(TM.TOKEN_DELAY)) then 
if (P3.DELAY_STATEMENT) then 
if (SEQUENCE_OF_STATEMENTS) then 


null; 
end if; -- if sequence_of_ statements 
return (TRUE); 
else 
P4.SYNTAX_ERROR( "Select alternative"); 
end if; -- if delay statement 


elsif (TM.MATCH(TM.TOKEN_TERMINATE)) then 
if (TM.MATCH( TM. TOKEN SEMICOLON)) then 
return (TRUE); 
else 
P4.SYNTAX ERROR( “Select alternative"); 
end if; -- if match(token_semicolon) 
else 
return (FALSE); 
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end if; -- if match( token_accept) 
end SELECT ALTERNATIVE; 


-- SELECT _ENTRY_CALL --> else SEQUENCE OF STATEMENTS 
== --> or delay DELAY_STATEMENT [SEQUENCE _OF STATEMENTS ?} 
function SELECT_ENTRY_CALL return boolean is 
STOP_TOKEN : TOKEN SCANNER.TOKEN_RECORD_TYPE; 
LOCATION ONE : positive; 
begin 
if (P4.PRINT_ CALLS) then 
P4.QUT_PUT("SELECT_ENTRY_ CALL"); 
end if; 
if (7M.MATCH(TM.TOKEN_ELSE)) then 
TM.MATCHED_TOKEN(STOP_TOKEN) ; 
if (CODE_BLOCKER.CURRENT STATEMENT COUNT /= 0) then 
LOCATION_ONE := CODE_BLOCKER.CURRENT_CODE_BLOCK_NUMBER; 
CODE_BLOCKER.EXIT_CODE_BLOCK(STOP_TOKEN. SOURCE) ; 
NET GENERATOR .DECISION OR( LOCATION ONE); 
else 
CODE BLOCKER.DELETE CODE BLOCK _ENTER; 
NET GENERATOR. EXPLICIT DECISION OR; 
end if; 
if (SEQUENCE _OF STATEMENTS) then 
return (TRUE); 
else 
P4.SYNTAX_ERROR( "Select entry cali"); 
end if; -- if sequence _of_statements 
elsif (TM.MATCH(TM.TOKEN OR)) then 
if (TM.MATCH( TM. TOKEN DELAY)) then 
if (P3.DELAY STATEMENT) then 
if (SEQUENCE _OF STATEMENTS) then 


null; 
end if; -- if sequence_of_ statements 
return (TRUE); 
else 
P4,SYNTAX_ERROR("Setect entry call"); 
end if; -- if delay statement 
else 
P4.SYNTAX_ERROR( "Select entry call"); 
end if; -- if match(token_detlay) 
else 
return (FALSE); 
end if; -- if match( token else) 


end SELECT ENTRY CALL; 


end PARSER 1; 
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moe TITLE: ADAFLOW == 
-- MODULE NAME: PACKAGE PARSER _2 == 
-- FILE NAME: PARSER2.ADS en 


-- DATE CREATED: 20 FEB 88 =< 
-- LAST MODIFIED: 28 APR 88 == 


-- AUTHOR(S): LT ALBERT J. GRECCO, USN -- 


-- BASED ON A MODIFIED ADA GRAMMAR DEVELOPED BY: =o 
ae LCDR JEFFREY L. NIEDER, USN 3S 
a LT KARL S. FAIRBANKS, JR., USN a 
== LCDR PAUL M. HERZIG, USN = 


-- DESCRIPTION: This package defines the functions == 
as that are the middle level productions for a top-down, ie 
as recursive descent parser. i 
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package PARSER 2 is 
function GENERIC _ACTUAL_PART return boolean; 
function GENERIC_ASSOCIATION return boolean; 
function GENERIC _FORMAL_ PARAMETER return boolean; 
function GENERIC_TYPE_DEFINITION return boolean; 
function PRIVATE_TYPE_DECLARATION return boolean; 
function TYPE_DECLARATION return boolean; 
function SUBTYPE DECLARATION return boolean; 
function DISCRIMINANT _PART return boolean; 
function DISCRIMINANT_SPECIFICATION return boolean; 
function TYPE DEFINITION return boolean; 
function RECORD_TYPE_DEFINITION return boolean; 
function COMPONENT LIST return boolean; 
function COMPONENT DECLARATION return boolean; 
function VARIANT PART return boolean; 
function VARIANT return boolean; 
function WITH_OR_USE_CLAUSE return boolean; 
function FORMAL_PART return boolean; 
function IDENTIFIER DECLARATION return boolean; 
function IDENTIFIER DECLARATION TAIL return boolean; 
function EXCEPTION_TAIL return boolean; 
function EXCEPTION CHOICE return boolean; 
function CONSTANT_TERM return boolean; 
function IDENTIFIER TAIL return boolean; 
function PARAMETER SPECIFICATION return boolean; 
function IDENTIFIER LIST return boolean; 
function MODE return boolean; 
function DESIGNATOR return boolean; 
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function SIMPLE STATEMENT return boolean; 

function ASSIGNMENT OR PROCEDURE CALL return boolean; 

function LABEL return boolean; 

function ENTRY DECLARATION return boolean; 

function REPRESENTATION CLAUSE return boolean; 

function RECORD REPRESENTATION CLAUSE return boolean; 
end PARSER 2; 
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— =< SSSSSSSSSSSSSSSCS SSS STS SF SS SSS SHS SSSSS SSE SSS SSE SSSSsesSsesSssesesesese sess. 


Some rl ile: ADAF LOW ae 
-- MODULE NAME: PACKAGE PARSER 2 ti 
-- FILE NAME: PARSER2 .ADB ran 


-- DATE CREATED: 20 FEB 88 ne 
-- LAST MODIFIED: 28 APR 88 a 


-- AUTHOR(S): LT ALBERT J. GRECCO, USN == 


-- BASED ON A MODIFIED ADA GRAMMAR DEVELOPED BY: == 
=e LCDR JEFFREY L. NIEDER, USN == 
ate LT KARL S. FAIRBANKS, JR., USN 2 
ed LCDR PAUL M. HERZIG, USN =< 


-- DESCRIPTION: This package implements the functions os 
== that are the middle level productions for a top-down, ie 
ad recursive descent parser. Each function is preceded a 
= by the grammar productions they are implementing. == 


—— SSSSSSSSSSSSSSSSS SSS SSS SSSSSSSES SES SS sSSSSSSSSSSSSSSseSEsSsSsSe ss sss sess _— 


with PARSER 3, PARSER_4, TOKEN_MATCHER, TOKEN SCANNER, 
CODE BLOCKER, SYMBOL_TABLE, NET GENERATOR; 


package body PARSER 2 is 
package TM renames TOKEN MATCHER; 
package P3 renames PARSER 3; 
package P4 renames PARSER 4; 


-- GENERIC_ACTUAL_PART --> (GENERIC_ASSOCIATION [, GENERIC_ASSOCIATION}* ) 


function GENERIC _ACTUAL_PART return boolean is 
begin 
if (P4.PRINT_ CALLS) then 
P4.QUT_PUT("GENERIC_ACTUAL_PART"); 
end if; 
if (TM.MATCH(TM. TOKEN LEFT PAREN)) then 
if (GENERIC_ASSOCIATION) then 
while (TM.MATCH(1TM. TOKEN COMMA)) loop 
if mot (GENERIC_ASSOCIATION) then 
P4.SYNTAX_ERROR( "Generic actual part"); 


end if; -- if not generic_association 


end loop; 

if (TM.MATCH(TM.TOKEN RIGHT PAREN)) then 
return (TRUE); 

else 
P4.SYNTAX_ERROR("Generic actual part"); 


end if; -- if match(token_right_paren) 


else 
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P4.SYNTAX_ERROR("Generic actual part"); 


end if; -- if generic association statement 
else 

return( FALSE); 
end if; -- if match(token_left_paren) 


end GENERIC_ACTUAL_PART; 
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-- GENERIC_ASSOCIATION --> [GENERIC_FORMAL_ PARAMETER ?] EXPRESSION 
function GENERIC ASSOCIATION return boolean is 
begin 
if (P4.PRINT CALLS) then 
P4.QUT_PUT( "GENERIC_ASSOCIATION"); 
end if; 
if (GENERIC _FORMAL_PARAMETER) then 
null; 
end if; -- if generic_formal_ parameter 
if (P3.EXPRESSION) then -- check generic_actual_ parameter 
return (TRUE); 
else 
return (FALSE); 
end if; -- if expression 
end GENERIC_ASSOCIATION; 


-- GENERIC_FORMAL_PARAMETER --> identifier => 
a5 --> string _literal => 
function GENERIC _FORMAL_PARAMETER return boolean is 
PEEK_AHEAD_TOKEN : TOKEN SCANNER. TOKEN _RECORD_TYPE; 
TEST_TOKEN : TOKEN _SCANNER.TOKEN RECORD TYPE; 
use TOKEN SCANNER; 
begin 
if (P4.PRINT CALLS) then 
P4.OUT_PUT("GENERIC_FORMAL_ PARAMETER"); 
end if; 
TEST_TOKEN.LEXEME := (others => ' '); 
TEST TOKEN CEXEME( 2 2) =) =: 
TEST _TOKEN -LEXEME SIZE := 2; 
TEST_TOKEN.TOKEN_TYPE := TOKEN SCANNER.DELIMITER; 
TM.NEXT TOKEN( PEEK _AHEAD_ TOKEN); 
1f (PEEK AHEAD TOKEN = TEST TOKEN) then 
if (TM.MATCH( TM. TOKEN _IDENTIFIER)) then 
if (TM.MATCH(TM. TOKEN _ARROW)) then 
return (TRUE); 


else 
P4.SYNTAX_ERROR("Generic formal parameter"); 
end if; -- if match(token_arrow) 


elsif (TM.MATCH(TM. TOKEN STRING LITERAL)) then 
if (TM.MATCH(TM. TOKEN ARROW)) then 
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return (TRUE); 


else 
P4.SYNTAX_ERROR("Generic formal parameter"); 
end if; -- if match(token_arrow) 
else 
P4.SYNTAX_ERROR("“Generic formal parameter"); 
end if; -- if match(token_identifier) 
else 
return (FALSE); 
end if; -- if lookahead token = "=>" 


end GENERIC_FORMAL_PARAMETER; 
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-- GENERIC_TYPE_DEFINITION --> ( <> ) 
== --> range <> 
a5 eaves: <2 
aS ==> delta <> 
= --> array ARRAY_TYPE_DEFINITION 
a --> access SUBTYPE_INDICATION 
function GENERIC TYPE DEFINITION return boolean is 
begin 
if (P4.PRINT_CALLS) then 
P4.QUT_PUT("GENERIC_TYPE_ DEFINITION"); 
end if; 
if (TM.MATCH(TM.TOKEN_LEFT_PAREN)) then 
if (TM.MATCH(TM. TOKEN BRACKETS)) then 
if (TM.MATCH(TM.TOKEN_RIGHT_PAREN)) then 
return (TRUE); 
else 
P4.SYNTAX_ERROR("Generic type definition”); 
end if; -- if match(token_right_paren) 
else 
P4.SYNTAX_ERROR("Generic type definition"); 
end if; -- if match(token_brackets) 
elsif (TM.MATCH(TM.TOKEN_RANGE)) or else (TM.MATCH( TM. TOKEN DIGITS) ) 
or else (TM.MATCH(TM.TOKEN_DELTA)) then 
if (TM.MATCH(TM.TOKEN BRACKETS)) then 
return (TRUE); 


else 
P4.SYNTAX_ERROR( "Generic type definition"); 
end if; -- if match(token_brackets) 


elsif (TM.MATCH(TM. TOKEN _ARRAY)) then 
if (P3.ARRAY_TYPE_DEFINITION) then 
return (TRUE); 


else 
P4.SYNTAX_ERROR( "Generic type definition"); 
end if; -- if array _type_definition 


elsif (TM.MATCH(TM.TOKEN ACCESS)) then 
if (P3.SUBTYPE INDICATION) then 
return (TRUE); 
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else 
P4.SYNTAX_ERROR( “Generic type definition"); 


end if; -- if subtype_indication 
else 
return (FALSE); 
end if; -- if match({token_left_paren) 


end GENERIC_TYPE DEFINITION; 


-- PRIVATE_TYPE_ DECLARATION --> [limited ?] private 
function PRIVATE _TYPE_DECLARATION return boolean is 
begin 

if (P4.PRINT_CALLS) then 

P4.OUT_PUT("PRIVATE_TYPE_DECLARATION") ; 
end if; 

if (TM.MATCH( TM. TOKEN _LIMITED)) then 

null; 

end if; 

if (TM.MATCH( TM. TOKEN _PRIVATE)) then 

return (TRUE); 

else 

return (FALSE); 

end if; 

end PRIVATE _TYPE_ DECLARATION; 


-- SUBTYPE DECLARATION --> identifier is SUBTYPE_INDICATION 
function SUBTYPE DECLARATION return boolean is 
begin 

if (P4.PRINT CALLS) then 

P4.QUT_PUT("SUBTYPE DECLARATION" ); 
end if; 
if (TM.MATCH(TM.TOKEN_IDENTIFIER)) then 
if (TM.MATCH(TM.TOKEN_IS)) then 
if (P3.SUBTYPE_INDICATION) then 
if (TM.MATCH( TM. TOKEN _SEMICOLON)) then 
return (TRUE); 


else 
P4.SYNTAX_ERROR( "Subtype declaration”); 
end if; -- if match( token_semicolon) 
else 
P4.SYNTAX_ERROR("Subtype declaration"); 
end if; -- if subtype_indication 
else 
P4.SYNTAX_ERROR( "Subtype declaration"); 
end if; -- if match(token_is) 


else 
return (FALSE); 
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end if; -- if match(token_identifier) 
end SUBTYPE DECLARATION; 


-- TYPE_DECLARATION --> identifier [DISCRIMINANT PART ? ]} 
-- [is PRIVATE_TYPE DECLARATION ?]; 
-- --> identifier [DISCRIMINANT PART ?]} 
-- {is TYPE_DEFINITION ?]; 
function TYPE_DECLARATION return boolean is 
begin 
if (P4.PRINT_CALLS) then 
P4.QUT_PUT("TYPE_DECLARATION"); 
end if; 
if (TM.MATCH(TM. TOKEN _IDENTIFIER)) then 
if (DISCRIMINANT _PART) then 


null; 
end if; -- if discriminant part 
if (TM.MATCH(TM.TOKEN IS)) then -- declaration is full_type if '‘is' 
if (PRIVATE _TYPE_DECLARATION) then 
null; 
elsif (TYPE_DEFINITION) then -- present else incomplete_type 
null; 
else 
P4.SYNTAX_ERROR( "Type declaration"); 
end if; -- if type_definition 
end if; -- if match(token_is) 


if (TM.MATCH(TM.TOKEN_SEMICOLON)) then 
return (TRUE); 


else 
P4.SYNTAX_ERROR( "Type declaration"); 
end if; -- if match(token_semicolon) 
else 
return (FALSE); 
end if; -- if match(token_identifier) 


end TYPE_DECLARATION; 


-- DISCRIMINANT PART --> (DISCRIMINANT SPECIFICATION 
-- [; DISCRIMINANT _SPECIFICATION]* ) 
function DISCRIMINANT PART return boolean is 
begin 
if (P4.PRINT_CALLS) then 
P4.QUT_PUT("DISCRIMINANT PART"); 
end if; 
if (TM.MATCH(TM. TOKEN _LEFT_PAREN)) then 
if (DISCRIMINANT SPECIFICATION) then 
while (TM.MATCH(TM.TOKEN SEMICOLON)) loop 
if not (DISCRIMINANT SPECIFICATION) then 
P4.SYNTAX_ERROR( "Discriminant part"); 
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end if; -- if not discriminant_specification 
end loop; 
if (TM.MATCH( TM. TOKEN RIGHT PAREN)) then 

return (TRUE); 


else 
P4.SYNTAX_ERROR( "Discriminant part"); 
end if; -- if match(token_right_paren) 
else 
P4.SYNTAX_ERROR( "Discriminant part"); 
end if; -- if discriminant_specification 
else 
return (FALSE); 
end if; -- if match({token_left_paren) 


end DISCRIMINANT PART; 
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-- DISCRIMINANT SPECIFICATION --> IDENTIFIER_LIST : NAME [:= EXPRESSION ?] 
function DISCRIMINANT SPECIFICATION return boolean is 
begin 
if (P4.PRINT_CALLS) then 
P4.QUT_PUT( "DISCRIMINANT SPECIFICATION"); 
end if; 
if (IDENTIFIER_LIST) then 
if (TM.MATCH(TM.TOKEN _COLON)) then 
if (P3.NAME) then -~ check for type_mark 
if (TM.MATCH( TM. TOKEN _ASSIGNMENT)) then 
if (P3.EXPRESSION) then 


null; 
else 
P4.SYNTAX_ERROR("Discriminant specification"); 
end if; -- if expression statement 
end if; -- if match( token_assignment ) 
return (TRUE); 
else 
P4.SYNTAX_ERROR( "Discriminant specification”); 
end if; -- if name statement 
else 
P4.SYNTAX_ERROR( "Discriminant specification"); 
end if; -- if match(token_colon) 
else 
return (FALSE); 
end if; -- if identifier_list statement 


end DISCRIMINANT SPECIFICATION; 


-- TYPE DEFINITION --> ENUMERATION TYPE DEFINITION 

-- --> INTEGER TYPE DEFINITION 

-- --> digits FLOATING OR FIXED POINT CONSTRAINT 
--> delta FLOATING OR FIXED POINT CONSTRAINT 
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== --> array ARRAY_TYPE_DEFINITION 
Se --> record RECORD_TYPE_DEFINITION 
== --> access SUBTYPE_INDICATION 
ae --> new SUBTYPE_INDICATION 
function TYPE_DEFINITION return boolean is 
begin 
if (P4.PRINT_CALLS) then 
P4.QUT_PUT("TYPE_DEFINITION"); 
end if; 
if (P4.ENUMERATION TYPE DEFINITION) then 
return (TRUE); 
elsif (P3.INTEGER_TYPE_DEFINITION) then 
return (TRUE); 
elsif (TM.MATCH(TM.TOKEN_DIGITS)) or else (TM.MATCH(TM.TOKEN DELTA)) then 
if (P3.FLOATING OR_FIXED_POINT_CONSTRAINT) then 
return (TRUE); 
else 
P4.SYNTAX_ERROR("Type definition"); 
end if; -- floating or_fixed_point_constraint 
elsif (TM.MATCH(TM.TOKEN_ARRAY)) then 
if (P3.ARRAY_TYPE_DEFINITION) then 
return (TRUE); 
else 
P4.SYNTAX_ERROR("Type definition"); 
end if; -- if array_type_def inition 
elsif (TM.MATCH( TM. TOKEN RECORD_STRUCTURE)) then 
if (RECORD_TYPE_ DEFINITION) then 
return (TRUE); 
else 
P4.SYNTAX_ERROR("Type definition"); 
end if; -- if record_type_definition 
elsif (TM.MATCH(TM. TOKEN ACCESS)) or else (TM.MATCH( TM. TOKEN _NEW)) then 
if (P3.SUBTYPE_ INDICATION) then 
return (TRUE); 
else 
P4.SYNTAX_ERROR("“Type definition"); 
end if; -- 1f subtype_indication 
else 
return (FALSE); 
end if; 
end TYPE DEFINITION; 
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-- RECORD_TYPE_DEFINITION --> COMPONENT LIST end record 
function RECORD _TYPE DEFINITION return boolean is 
begin 
if (P4.PRINT_ CALLS) then 
P4.QUT_PUT( "RECORD TYPE DEFINITION"); 
end if; 
if (COMPONENT LIST) then 
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if (TM.MATCH(TM.TOKEN_END)) then 
if (TM.MATCH(TM. TOKEN _RECORD_STRUCTURE)) then 
return (TRUE); 


else 
P4.SYNTAX_ERROR( “Record type definition"); 
end if; -- if match(token_record-structure) 
else 
P4,.SYNTAX_ERROR( "Record type definition"); 
end if; -- if match(token_end) 
else 
return (FALSE); 
end if; -- if Component_list statement 


end RECORD TYPE_DEFINITION; 


-- COMPONENT_LIST --> [COMPONENT _DECLARATION]* [VAARIANT_PART ?]} 
-- ==) ini: 
function COMPONENT_LIST return boolean is 
begin 
if (P4.PRINT_CALLS) then 
P4.O0UT_PUT( "COMPONENT LIST"); 
end if; 
while (COMPONENT DECLARATION) loop 
null; 
end loop; 
if (VARIANT_PART) then 
null; 
elsif (TM.MATCH(TM. TOKEN NULL)) then 
if (TM.MATCH(TM.TOKEN_SEMICOLON)) then 
null; 
end if; 
end if; 
return (TRUE); 
end COMPONENT LIST; 
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-- COMPONENT DECLARATION --> IDENTIFIER_LIST : SUBTYPE_INDICATION 
a [:= EXPRESSION ?] ; 
function COMPONENT DECLARATION return boolean is 
begin 
if (P4.PRINT CALLS) then 
P4.QUT_PUT( "COMPONENT DECLARATION" ); 
end if; 
if (IDENTIFIER LIST) then 
if (TM.MATCH(TM.TOKEN COLON)) then 
if (P3.SUBTYPE_ INDICATION) then 
if (T.MATCH( TM. TOKEN ASSIGNMENT)) then 
if (P3.EXPRESSION) then 
if (TM.MATCH(TM. TOKEN SEMICOLON)) then 
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return (TRUE); 


else 
P4.SYNTAX_ERROR( "Component declaration"); 
end if; -- if match(token_semicolon) 
else 
P4.SYNTAX_ERROR( "Component declaration"); 
end if; -- if expression statement 
end if; -- if match(token_assignment) 


if (TM.MATCH(TM. TOKEN SEMICOLON)) then 
return (TRUE); 


else 
P4.SYNTAX_ERROR( "Component declaration"); 
end if; -- if match(token_semicolon) 
else 
P4.SYNTAX_ERROR( "Component declaration"); 
end if; -- if subtype indication statement 
else 
P4.SYNTAX_ERROR( "Component declaration"); 
end if; -- if match(token_colon) 
else 
return (FALSE); 
end if; -- if identifier_list statement 


end COMPONENT DECLARATION; 


-- VARIANT_PART --> case identifier is [VARIANT]+ end case ; 
function VARIANT PART return boolean is 
begin 
if (P4.PRINT_ CALLS) then 
P4.QUT_PUT("VARIANT_PART"); 
end if; 
if (TM.MATCH(TM.TOKEN CASE)) then 
if (TM.MATCH(TM.TOKEN_IDENTIFIER)) then 
if (TM.MATCH(TM.TOKEN_IS)) then 
if (VARIANT) then 
while (VARIANT) loop 
null; 
end loop; 
if (TM.MATCH(TM.TOKEN_END)) then 
if (TM.MATCH( TM. TOKEN CASE)) then 
if (TM.MATCH(TM. TOKEN SEMICOLON)) then 
return (TRUE); 


else 
P4.SYNTAX_ERROR( "Variant part"); 
end if; -- if match(token_semicolon) 
else 
P4.SYNTAX_ERROR( "Variant part"); 
end if; -- if match(token_case) 
else 


P4.SYNTAX ERROR( "Variant part"); 


oi 


end if; -- if match( token_end) 


else 
P4.SYNTAX_ERROR( "Variant part"); 
end if; -- if variant statement 
else 
P4.SYNTAX_ERROR( "Variant part"); 
end if; -- if match(token_is) 
else 
P4.SYNTAX_ERROR( "Variant part"); 
end if; -- if match({token_identifier) 
else 
return (FALSE); 
end if; -- if match(token_case) 


end VARIANT PART; 


-- VARIANT --> when CHOICE [| CHOICE]* => COMPONENT LIST 
function VARIANT return boolean is 
begin 
if (P4.PRINT_CALLS) then 
P4.QUT_PUT("VARIANT"); 
end if; 
if (TM.MATCH(TM. TOKEN _WHEN)) then 
if (P3.CHOICE) then 
while (TM.MATCH( TM. TOKEN _BAR)) loop 
if not (P3.CHOICE) then 
P4.SYNTAX_ERROR( "Variant" ); 
end if; -- if not choice statement 
end loop; 
if (TM.MATCH(TM. TOKEN ARROW)) then 
if (COMPONENT LIST) then 
return (TRUE); 


else 
P4.SYNTAX_ERROR( "Variant" ); 
end if; -- if component_list statement 
else 
P4.SYNTAX_ERROR( "Variant" ); 
end if; -- if match(token_arrow) 
else 
P4.SYNTAX_ERROR("Variant"); 
end if; -- if choice statement 
else 
return (FALSE); 
end if; -- if match(token_when) 


end VARIANT; 


~~ WITH _OR_USESCUAUSE --> sadentifier [, identitier |* =; 
function WITH _OR_USE CLAUSE return boolean is 


112 


begin 
if (P4.PRINT CALLS) then 
P4.QUT_PUT("WITH_OR_USE CLAUSE"); 
end if; 
if (TM.MATCH(TM.TOKEN_IDENTIFIER)) then 
while (TM.MATCH(TM.TOKEN COMMA)) loop 
if not (TM.MATCH( TM. TOKEN _IDENTIFIER)) then 
P4.SYNTAX_ERROR( "With or use clause"); 
end if; 
end loop; 
if (TM.MATCH(TM. TOKEN SEMICOLON)) then 
return (TRUE); 


else 
P4.SYNTAX_ERROR("With or use clause"); 
end if; -- if match(token_semicolon) 
else 
return (FALSE); 
end if; -- if match(token_identifier) 


end WITH_OR_USE_CLAUSE; 
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-- FORMAL_PART --> (PARAMETER SPECIFICATION [; PARAMETER _SPECIFICATION]* ) 
function FORMAL_PART return boolean is 
begin 
if (P4.PRINT_CALLS) then 
P4.OUT_PUT("FORMAL_PART"); 
end if; 
if (TM.MATCH(TM.TOKEN_LEFT_PAREN)) then 
if (PARAMETER SPECIFICATION) then 
while (TM.MATCH(TM.TOKEN SEMICOLON) ) loop 
if mot (PARAMETER SPECIFICATION) then 
P4.SYNTAX_ERROR( "Formal part"); 
end if; -- if not parameter_specif ication 
end loop; 
if (TM.MATCH(TM.TOKEN RIGHT _PAREN)) then 
return (TRUE); 
else 
P4.SYNTAX_ERROR( “Formal part"); 
end if; -- if match(token_right_paren) 
else 
P4.SYNTAX_ERROR( "Formal part"); 
end if; -- if parameter specification 
else 
return (FALSE); 
end if; -- if match(token_left_paren) 
end FORMAL_PART; 
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-- IDENTIFIER DECLARATION --> IDENTIFIER_LIST : IDENTIFIER DECLARATION _TAIL 
function IDENTIFIER_DECLARATION return boolean is 
begin 
if (P4.PRINT CALLS) then 
P4.OUT PUT("IDENTIFIER DECLARATION"); 
end if; 
if (IDENTIFIER LIST) then 
if (TM.MATCH(TM.TOKEN_COLON)) then 
if (IDENTIFIER DECLARATION TAIL) then 
return (TRUE); 


else 
P4.SYNTAX_ERROR( "Identifier declaration"); 
end if; -- if identifier list 
else 
P4.SYNTAX_ERROR( "Identifier declaration"); 
end if; -- if match(token_colon) 
else 
return( FALSE); 
end if; -- if identifier_list 


end IDENTIFIER DECLARATION; 


-- IDENTIFIER_DECLARATION_TAIL --> exception EXCEPTION_TAIL 
ae --> constant CONSTANT TERM 
== --> array ARRAY_TYPE DEFINITION 
ae [:= EXPRESSION ?] ; 
a= --> NAME IDENTIFIER_TAIL 
function IDENTIFIER_DECLARATION_TAIL return boolean is 
begin 
if (P4.PRINT CALLS) then 
P4.O0UT_PUT( "IDENTIFIER DECLARATION TAIL"); 
end if; 
if (TM.MATCH(TM. TOKEN _EXCEPTION)) then 
if (EXCEPTION_TAIL) then 
return (TRUE); 


else 
P4.SYNTAX_ERROR("“Identifier declaration tail"); 
end if; -- if exception tail statement 


elsif (TM.MATCH(TM. TOKEN _CONSTANT)) then 
if (CONSTANT TERM) then 
return (TRUE); 


else 
P4.SYNTAX_ERROR( "Identifier declaration tail"); 
end if; -- if constant_term statement 


elsif (TM.MATCH(TM.TOKEN ARRAY)) then 
if (P3. ARRAY TYPE DEFINITION) then 
if (TM.MATCH(TM. TOKEN ASSIGNMENT)) then 
if (P3.EXPRESSION) then 
null; 
else 
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P4.SYNTAX_ERROR(“Identifier declaration tail"); 


end if; -- if expression statement 
end if; -- if match(token_assignment) 
else 
P4.SYNTAX_ERROR("Identifier declaration tail"); 
end if; -- if array _type definition 


if (TM.MATCH(TM.TOKEN SEMICOLON)) then 
return (TRUE); 


else 
P4.SYNTAX_ERROR( "Identifier declaration tail"); 
end if; -- if match(token_semicolon) 


elsif (P3.NAME) then 
if (IDENTIFIER TAIL) then 
return (TRUE); 


else 
P4.SYNTAX_ERROR("Identifier declaration tail"); 
end if; -- if identifier_tail 
else 
return (FALSE); 
end if; -- if match(token_exception) 


end IDENTIFIER_DECLARATION TAIL; 


SeeeXCEPTION TAIL --> ; 
oe --> renames NAME ; 
function EXCEPTION TAIL return boolean is 
begin 
if (P4.PRINT CALLS) then 
P4.QUT_PUT( "EXCEPTION TAIL”); 
end if; 
if (T™M.MATCH(TM. TOKEN _SEMICOLON)) then 
return (TRUE); 
elsif (TM.MATCH( TM. TOKEN _RENAMES)) then 
if (P3.NAME) then 
if (TM.MATCH( TM. TOKEN SEMICOLON)) then 
return (TRUE); 
else 
P4.SYNTAX_ERROR("Exception tail"); 
end if; -- if match(token_ semicolon) 
else 
P4.SYNTAX_ERROR("Exception tail"); 
end if; -- if name statement 
else 
return (FALSE); 
end if; -- if match(token_semicolon) 
end EXCEPTION TAIL; 
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-- EXCEPTION CHOICE --> NAME 
=e ==) SOChens 
function EXCEPTION CHOICE return boolean is 
begin 
if (P4.PRINT_CALLS) then 
P4.QUT_PUT( "EXCEPTION CHOICE"); 
end 1f; 
if (P3.NAME) then 
return (TRUE); 
elsif (TM.MATCH(TM. TOKEN OTHERS)) then 
return (TRUE); 
else 
return (FALSE); 
end if; 
end EXCEPTION CHOICE; 
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-- CONSTANT_TERM --> array ARRAY_TYPE_DEFINITION [:= EXPRESSION ?] ; 
25 ==> $= EXPRESSION : 
= --> NAME IDENTIFIER_TAIL 
function CONSTANT _TERM return boolean is 
begin 
if (P4.PRINT_CALLS) then 
P4.QUT_PUT( "CONSTANT_TERM") ; 
end if; 
if (TM.MATCH(TM. TOKEN _ARRAY)) then 
if (P3.ARRAY_TYPE_DEFINITION) then 
if (TM.MATCH(TM. TOKEN ASSIGNMENT)) then 
if (P3.EXPRESSION) then 


null; 
else 
P4.SYNTAX_ERROR( "Constant term"); 
end if; -- if expression statement 
end if; -- if match(token_assignment) 
else 
P4.SYNTAX_ERROR( "Constant term"); 
end if; -- if array_type_definition 


if (TM.MATCH(TM. TOKEN SEMICOLON)) then 
return (TRUE); 
else 
P4.SYNTAX_ERROR( "Constant term"); 
end if; -- if match(token_semicolon) 
elsif (TM.MATCH( TM. TOKEN _ASSIGNMENT)) then 
if (P3.EXPRESSION) then 
if (TM.MATCH(TM. TOKEN _SEMICOLON)) then 
return (TRUE); 
else 
P4.SYNTAX_ERROR( "Constant term"); 
end wf: -- if match( token semicolon) 
else 
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P4.SYNTAX_ERROR("Constant term"); 
end if; -- if expression statement 
elsif (P3.NAME) then 
if (IDENTIFIER TAIL) then 
return (TRUE); 


else 
P4.SYNTAX_ERROR( "Constant term"); 
end if; -- if identifier_tail statement 
else 
return (FALSE); 
end if; -- if match(token_array) 


end CONSTANT_TERM; 


-- IDENTIFIER TAIL --> [CONSTRAINT ?] [:= EXPRESSION ?] ; 
Se --> [renames NAME ?] ; 
function IDENTIFIER TAIL return boolean is 
begin 
if (P4.PRINT_ CALLS) then 
P4,0UT_PUT("IDENTIFIER TAIL"); 
end if; 
if (P3.CONSTRAINT) then 
null; 
end if; -- if constraint statement 
if (TM.MATCH( TM. TOKEN _RENAMES)) then 
if (P3.NAME) then 


null; 
else 
P4.SYNTAX_ERROR("Identifier tail"); 
end if; -- if name statement 
end if; -- if match(token_renames ) 


if (TM.MATCH( TM. TOKEN _ASSIGNMENT)) then 
if (P3.EXPRESSION) then 


null; 
else 
P4.SYNTAX_ERROR("“Identifier tail"); 
end if; -- if expression statement 
end if; -- if match(token_assignment ) 


if (TM.MATCH(TM.TOKEN SEMICOLON)) then 
return (TRUE); 
else 
return (FALSE); 
end if; -- if match( token_semicolon) 
end IDENTIFIER TAIL; 


-~ PARAMETER SPECIFICATION --> IDENTIFIER LIST : MODE NAME [:= EXPRESSION ?] 
function PARAMETER SPECIFICATION return boolean is 
begin 
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if (P4.PRINT CALLS) then 

P4.QUT_PUT( "PARAMETER SPECIFICATION"); 
end if; 
if (IDENTIFIER_LIST) then 

if (TM.MATCH(TM.TOKEN COLON)) then 

if (MODE) then 
if (P3.NAME) then -- check for type_mark 
if (TM.MATCH(TM. TOKEN ASSIGNMENT)) then 
if (P3.EXPRESSION) then 


null; 
else 
P4.SYNTAX_ERROR("Parameter specif ication”); 
end if; -- if expression statement 
end if; -- if match(token_assignment) 
return (TRUE); 
else 
P4.SYNTAX_ERROR("Parameter specification"); 
end if; -- if name statement 
else 
P4.SYNTAX_ERROR("Parameter specification"); 
end if; -- if mode statement 
else 
P4.SYNTAX_ERROR( "Parameter specification"); 
end if; -- if match(token_colon) 
else 
return (FALSE); 
end if; -- if identifier_list statement 


end PARAMETER_SPECIFICATION; 
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-- IDENTIFIER LIST --> identifier [, identifier]* 
function IDENTIFIER LIST return boolean is 
TEMP TOKEN : TOKEN SCANNER. TOKEN RECORD TYPE; 
LOCATION : natural; 
begin 
if (P4.PRINT_ CALLS) then 
P4OUTLPUT(” LOENTIFIER_EISI”); 
end if; 
if (TM.MATCH(1TM. TOKEN IDENTIFIER)) then 
LOCATION := CODE_BLOCKER.CURRENT CODE_BLOCK_NUMBER; 
TM.MATCHED_TOKEN( TEMP_TOKEN); 
SYMBOL_TABLE.INSERT SYM TAB( TEMP_TOKEN.LEXEME(1.. TEMP TOKEN.LEXEME SIZE), 
SYMBOL _TABLE .OBJECT_DECLARATION_TAG, LOCATION); 
while (TM.MATCH( TM. TOKEN COMMA)) loop 
if (™M.MATCH(TM. TOKEN _IDENTIFIER)) then 
TM.MATCHED TOKEN( TEMP TOKEN); 
SYMBOL_TABLE.INSERT_SYM_TAB( TEMP_TOKEN.LEXEME(1..TEMP_TOKEN.LEXEME SIZE), 
SYMBOL _TABLE .OBJECT DECLARATION_TAG, 
LOCATION); 
else 
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P4.SYNTAX_ERROR(“Identifier list"); 


end if; -- if not match(token_identifer) statement 
end loop; 
return (TRUE); 
else 
return (FALSE); 
end if; -- if match(token_identifier) statement 


end IDENTIFIER_LIST; 


-- MODE --> [in ?] 


-- --> in out 
2 =i nO Lite 
function MODE return boolean is 


begin 
if (P4.PRINT_CALLS) then 
P4.QUT_PUT("MODE") ; 
end if; 
if (TM.MATCH(TM.TOKEN_IN)) then 
if (TM.MATCH( TM. TOKEN _OUT)) then 
null; 
end if; 
elsif (TM.MATCH(TM.TOKEN OUT)) then 
null; 
end if; 
return (TRUE); 
end MODE; 
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-- DESIGNATOR --> identifier 
a --> string literal 
function DESIGNATOR return boolean is 
begin 
if (P4.PRINT_CALLS) then 
P4.OUT_PUT( "DESIGNATOR" ); 
end if; 
if (TM.MATCH(TM.TOKEN IDENTIFIER)) then 
return (TRUE); 
elsif (TM.MATCH(TM. TOKEN STRING LITERAL)) then 
return (TRUE); 
else 
return (FALSE); 
end if; 
end DESIGNATOR; 
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-- SIMPLE STATEMENT --> null ; 
-- ~~> ASSIGNMENT OR PROCEDURE CALL 


eS 


aoe --> exit EXIT_STATEMENT 
ao --> return RETURN STATEMENT 
— --> goto GOTO_STATEMENT 
== --> delay DELAY _STATEMENT 
== --> abort ABORT_STATEMENT 
== --> raise RAISE STATEMENT 
function SIMPLE STATEMENT return boolean is 
begin 
if (P4.PRINT_CALLS) then 
P4.QOUT_PUT("SIMPLE_STATEMENT"); 
end if; 
if (TM.MATCH(TM.TOKEN NULL)) then 
if (TM.MATCH(TM.TOKEN_SEMICOLON)) then 
CODE_BLOCKER. INCREMENT STATEMENT COUNT; 
return (TRUE); 


else 
P4.SYNTAX_ERROR("Simple statement"); 
end if; 
elsif (ASSIGNMENT OR PROCEDURE CALL) then -- includes a check for a 
return (TRUE); -- code statement and an 
elsif (TM.MATCH(TM.TOKEN_EXIT)) then -- entry call statement. 


if (P3.EXIT_STATEMENT) then 
CODE_BLOCKER.INCREMENT STATEMENT COUNT; 
return (TRUE); 
else 
P4.SYNTAX_ERROR( "Simple statement”) ; 
end if; 
elsif (TM.MATCH(TM.TOKEN RETURN)) then 
if (P3.RETURN STATEMENT) then 
CODE BLOCKER. INCREMENT STATEMENT COUNT; 
return (TRUE); 
else 
P4.SYNTAX_ERROR("Simple statement"); 
end if; 
elsif (TM.MATCH(TM. TOKEN GOTO)) then 
if (P3.GOTO_STATEMENT) then 
return (TRUE); 
else 
P4.SYNTAX_ERROR( "Simple statement”); 
end if; 
elsif (TM.MATCH(TM. TOKEN DELAY)) then 
if (P3.DELAY_STATEMENT) then 
CODE BLOCKER. INCREMENT STATEMENT COUNT ; 
return (TRUE); 
else 
P4.SYNTAX_ERROR("Simple statement"); 
end if; 
elsif (TM.MATCH(TM. TOKEN ABORT)) then 
if (P3.ABORT STATEMENT) then 
CODE BLOCKER. INCREMENT STATEMENT COUNT; 
rectucn GURUE: 
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else 
P4.SYNTAX_ERROR("“Simplie statement"); 
end if; 
elsif (TM.MATCH(TM.TOKEN_RAISE)) then 
if (P3.RAISE STATEMENT) then 
COOE BLOCKER. INCREMENT STATEMENT COUNT; 
return (TRUE); 
else 
P4.SYNTAX_ERROR( "Simple statement"); 
end if; 
else 
return (FALSE); 
end if; 
end SIMPLE STATEMENT; 


-- ASSIGNMENT_OR_ PROCEDURE _CALL --> NAME := EXPRESSION ; 
== --> NAME ; 
function ASSIGNMENT OR_PROCEOURE CALL return boolean is 
SEARCH POINTER : SYMBOL_TABLE.SYM TAB_ACCESS; 


SEARCH_TOKEN : TOKEN SCANNER. TOKEN RECORD TYPE; 
LOCATION ONE > positive; 

use SYMBOL_TABLE; 

begin 


if (P4.PRINT_ CALLS) then 
P4.QUT_PUT("ASSIGNMENT_OR_PROCEDURE_CALL"); 
end if; 
SYMBOL_TABLE.SAVE_CURRENT_ENTRY; 
if (P3.NAME) then 
if (TM.MATCH(TM.TOKEN ASSIGNMENT)) then 
if (P3.EXPRESSION) then 
TM.MATCHEO_TOKEN( SEARCH_TOKEN) ; 
SEARCH POINTER := SYMBOL_TABLE.RETRIEVE SYM; 
if ((SEARCH_POINTER /= null) and then 
(SEARCH_POINTER.TAG_TYPE = SYMBOL_TABLE.FUNCTION DECLARATION _TAG)) then 
LOCATION_ONE := CODE_BLOCKER.CURRENT_ CODE_BLOCK_NUMBER; 
COOE_BLOCKER.INCREMENT_STATEMENT_ COUNT; 
COOE_BLOCKER.EXIT_COOE BLOCK(SEARCH_TOKEN.SOURCE) ; 
NET_GENERATOR.CALL(LOCATION ONE, SEARCH POINTER); 
COOE_BLOCKER.ENTER CODE BLOCK(SEARCH_TOKEN.SOURCE, ""); 
else 
CODE BLOCKER.INCREMENT STATEMENT COUNT; 
end if; 
if (TM.MATCH(TM. TOKEN SEMICOLON)) then 
SYMBOL_TABLE.RESTORE CURRENT ENTRY; 


return (TRUE); ~- parsed an assignment statement 
else 
P4.SYNTAX_ERROR( "Assignment or procedure cali"); 
end if; -- if match(token_semicotlon) 
else 
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P4.SYNTAX_ERROR( "Assignment or procedure call"); 

end if; -- if expression statement 

elsif (TM.MATCH(TM.TOKEN SEMICOLON)) then 

TM.MATCHED_TOKEN( SEARCH_ TOKEN); 

SEARCH POINTER := SYMBOL_TABLE .RETRIEVE_SYM; 

if ((SEARCH_POINTER /= null) and then 

(SEARCH_POINTER.TAG_TYPE = SYMBOL_TABLE.PROCEDURE DECLARATION_TAG)) then 
LOCATION_ONE := CODE_BLOCKER.CURRENT_CODE_BLOCK_NUMBER; 
CODE BLOCKER.INCREMENT STATEMENT COUNT; 
CODE_BLOCKER.EXIT_CODE_BLOCK(SEARCH_TOKEN. SOURCE ); 
NET _GENERATOR.CALL(LOCATION ONE, SEARCH_POINTER); 
CODE_BLOCKER.ENTER_CODE_BLOCK(SEARCH_TOKEN.SOURCE, ""); 

elsif ((SEARCH_ POINTER /= null) and then 

(SEARCH_POINTER.TAG_ TYPE = SYMBOL_TABLE.ENTRY_TAG)) then 
LOCATION_ONE := CODE_BLOCKER.CURRENT_CODE_BLOCK_NUMBER;; 
CODE_BLOCKER.INCREMENT_STATEMENT_ COUNT; 
CODE_BLOCKER.EXIT_CODE_BLOCK( SEARCH_TOKEN.SOURCE ) ; 
NET_GENERATOR. ENTRY _CALL(LOCATION_ONE, SEARCH_POINTER); 
CODE_BLOCKER.ENTER_CODE_BLOCK( SEARCH_TOKEN.SOURCE, ""); 


end if; 
SYMBOL_TABLE.RESTORE_CURRENT_ENTRY; 
return (TRUE); -- parsed a procedure call statement 
else 
P4.SYNTAX_ERROR( "Assignment or procedure call"); 
end if; -- if match(token_assignment) 
else 


SYMBOL_TABLE .RESTORE_CURRENT_ENTRY; 
return (FALSE); 
end if; -- if name statement 
end ASSIGNMENT _OR_PROCEODURE_CALL; 


-- LABEL --> << identifier >> 
function LABEL return boolean is 
START_TOKEN : TOKEN_SCANNER. TOKEN _RECORD_TYPE; 
LOCATION_ONE : positive; 
LOCATION_TWO : positive; 
use SYMBOL_TABLE; 
begin 
if (P4.PRINT CALLS) then 
P4.OUT_PUT("LABEL"); 
end if; 
if (TM.MATCH( TM. TOKEN LEFT BRACKET)) then 
if (TM.MATCH( TM. TOKEN IDENTIFIER)) then 
TM.MATCHED_TOKEN(START_TOKEN); 
if (TM.MATCH(TM. TOKEN RIGHT BRACKET)) then 
if (CODE _BLOCKER.CURRENT STATEMENT COUNT /= 0) then 
LOCATION ONE := CODE BLOCKER.CURRENT_CODE BLOCK NUMBER; 
CODE BLOCKER.EXIT CODE BLOCK(START_ TOKEN. SOURCE); 
CODE BLOCKER. ENTER CODE BLOCK(START_TOKEN.SOURCE, “LABELLED BLOCK"); 
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LOCATION TWO := CODE BLOCKER.CURRENT CODE _BLOCK_NUMBER; 
CODE_BLOCKER. INCREMENT STATEMENT COUNT; 
NET_GENERATOR.CONNECT BLOCKS(LOCATION_ONE, LOCATION _TWO); 
else 
CODE BLOCKER.DELETE CODE_BLOCK_ENTER; 
CODE _BLOCKER.ENTER CODE _BLOCK(START_TOKEN.SOURCE, "LABELLED BLOCK"); 
CODE_BLOCKER. INCREMENT STATEMENT COUNT; 
LOCATION TWO := CODE_BLOCKER.CURRENT CODE _BLOCK_NUMBER; 
end if; 
if (SYMBOL_TABLE.FIND_KEY(START_TOKEN.LEXEME(1.. 
START_TOKEN.LEXEME SIZE)) = null) then 
SYMBOL_TABLE.INSERT_ SYM_TAB(START_TOKEN. 
LEXEME(1..START_TOKEN.LEXEME_ SIZE), 
SYMBOL_TABLE.LABEL_NAME, LOCATION_TWO); 
else 
SYMBOL_TABLE .UPDATE_SYM_TAB( LOCATION _TwO) ; 
end if; 
return (TRUE); 
else 
P4.SYNTAX_ERROR(“Label"); 
end if; -- if match(token_right_bracket) 
else 
P4.SYNTAX_ERROR( “Labet"); 
end if; -- if match(token_identifier) 
else 
return (FALSE); 
end if; -- if match(token_left_bracket) 
end LABEL; 


-- ENTRY_DECLARATION --> entry identifier [(DISCRETE_RANGE) ?] 
== [FORMAL_PART ?] ; 
function ENTRY DECLARATION return boolean is 
START_TOKEN : TOKEN _SCANNER.TOKEN_RECORD_TYPE; 
begin 
if (P4.PRINT_ CALLS) then 
P4.QUT_PUT( "ENTRY DECLARATION") ; 
end if; 
if (TM.MATCH(TM.TOKEN ENTRY)) then 
if (TM.MATCH(TM. TOKEN _IDENTIFIER)) then 
TM.MATCHED_TOKEN(START_TOKEN); 
SYMBOL_TABLE.INSERT_SYM TAB(START_TOKEN.LEXEME(1.. 
START_TOKEN.LEXEME SIZE), SYMBOL_TABLE.ENTRY_TAG, 0); 
SYMBOL_TABLE.INSERT_SYM_TAB("END”", SYMBOL_TABLE.LABEL_NAME, 0); 
if (TM.MATCH(TM. TOKEN LEFT PAREN)) then 
if (P3.DISCRETE RANGE) then 
if (TM.MATCH(TM. TOKEN RIGHT PAREN)) then 
null; 
else 
P4.SYNTAX_ERROR( "Entry declaration"); 
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end if; -- if match(token_right_paren) 
else 
P4.SYNTAX_ERROR( "Entry declaration"); 
end if; -- if discrete range statement 
end if; -~- if match(token_left_paren) 
if (FORMAL PART) then 
null; 
end if; -- if formal_part statement 
if (T.MATCH(TM.TOKEN SEMICOLON)) then 
TM.MATCHED_TOKEN( START_TOKEN) ; 
SYMBOL _TABLE.EXIT_SCOPE; 
return (TRUE); 
else 
P4.SYNTAX_ERROR("“Entry declaration"); 
end if; -- if match(token_semicolon) 
else 
P4.SYNTAX_ERROR( “Entry declaration"); 
end if; -- if match(token_identifier) 
else 
return (FALSE); 
end if; -- if match(token_entry) 
end ENTRY_DECLARATION; 
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-- REPRESENTATION CLAUSE --> for NAME use record RECORD_REPRESENTATION CLAUSE 
ao --> for NAME use [at ?] SIMPLE_EXPRESSION; 
function REPRESENTATION_CLAUSE return boolean is 
begin 
if (P4.PRINT_CALLS) then 
P4.OUT_PUT( "REPRESENTATION CLAUSE" ) ; 
end if; 
if (TM.MATCH(TM. TOKEN FOR)) then 
if (P3.MAME) then 
if (TM.MATCH(TM. TOKEN _USE)) then 
if (TM.MATCH( TM. TOKEN RECORD STRUCTURE)) then 
if (RECORD_REPRESENTATION CLAUSE) then 
return (TRUE); 


else 
P4.SYNTAX_ERROR("Representation clause"); 
end if; -- if record _representation_clause 


elsif (TM.MATCH(TM. TOKEN _AT)) then 
if (P3.SIMPLE_EXPRESSION) then 
if (TM.MATCH(TM. TOKEN SEMICOLON)) then 
return (TRUE); 
else 
P4.SYNTAX_ERROR( "Representation clause"); 
end if; -- if match( token semicolon) 
else 
P4.SYNTAX ERROR( "Representation clause"); 
end 1f; -- 1f simple _expression statement 
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elsif (P3.SIMPLE_EXPRESSION) then 
if (TM.MATCH( TM. TOKEN SEMICOLON) ) then 
return (TRUE); 


else 
P4.SYNTAX_ERROR( "Representation clause"); 
end if; -- if match(token_semicolon) 
else 
P4.SYNTAX_ERROR("Representation clause"); 
end if; -- if match(token_record) 
else 
P4.SYNTAX_ERROR( “Representation clause”); 
end if; -- if match(token_use) 
else 
P4.SYNTAX_ERROR( "Representation clause"); 
end if; -- if name statement 
else 
return (FALSE); 
end if; -- if match(token_for) 


end REPRESENTATION CLAUSE; 


-- RECORD_REPRESENTATION CLAUSE --> [at mod SIMPLE_EXPRESSION ?]} 
a [NAME at SIMPLE_EXPRESSION range RANGES ]* 
ty end record ; 
function RECORD_REPRESENTATION CLAUSE return boolean is 
begin 
if (P4.PRINT CALLS) then 
P4,.OUT_PUT("RECORD_REPRESENTATION CLAUSE"); 
end if; 
if (TM.MATCH(TM.TOKEN_AT)) then 
if (™M.MATCH(TM.TOKEN MOD)) then 
if (P3.SIMPLE_ EXPRESSION) then 


null; 
else 
P4.SYNTAX_ERROR( “Record representation clause"); 
end if; -- if simple expression 
else 
P4.SYNTAX_ERROR( "Record representation clause"); 
end if; -- if match(token_mod) 
end if; -- if match( token at) 


while (P3.NAME) loop 
if (TM.MATCH(TM.TOKEN_AT)) then 
if (P3.SIMPLE_EXPRESSION) then 
if (TM.MATCH( TM. TOKEN _RANGE)) then 
if (P3.RANGES) then 


null; 
else 
P4.SYNTAX_ERROR(“Record representation clause"); 
end if; -- if ranges statement 
else 
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P4.SYNTAX_ERROR("“Record representation clause"); 


end if; -- if match(token_range) 
else 
P4.SYNTAX_ERROR("Record representation clause"); 
end if; -- if simple_expression 
else 
P4.SYNTAX_ERROR("Record representation clause"); 
end if; -- if match( token_at) 
end loop; 


if (TM.MATCH(TM.TOKEN _END)) then 
if (TM.MATCH( TM. TOKEN RECORD_STRUCTURE)) then 
if (TM.MATCH(TM.TOKEN SEMICOLON)) then 
return (TRUE); 


else 
P4.SYNTAX_ERROR("Record representation clause"); 
end if; -- if match(token_semicolon) 
else 
P4.SYNTAX_ERROR( "Record representation clause"); 
end if; -- if match(token_record structure) 
else 
return (FALSE); 
end if; -- if match(token_end) 


end RECORD_REPRESENTATION_CLAUSE ; 


end PARSER 2; 


126 


——SFSSSSSSSSSSSSSSES SSS SC SSSSSSESSSSSSSSSSC SS SS SESS SESS sSsSSSsESSESeseseseseses__ 


TITLE : ADAF LOW 


MODULE NAME: PACKAGE PARSER 3 


-- FILE NAME: PARSER3.ADS = 
-- DATE CREATED: 20 FEB 88 = 
-- LAST MODIFIED: 28 APR 88 os 


AUTHOR(S): LT ALBERT J. GRECCO, USN 

BASED ON A MODIFIED ADA GRAMMAR DEVELOPED BY: 
LCDR JEFFREY L. NIEDER, USN 
LT KARL S. FAIRBANKS, JR., USN 
LCDR PAUL M. HERZIG, USN 


DESCRIPTION: This package defines the functions 


that make up the baseline productions for a top-down, 
recursive descent parser. 
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package PARSER_3 is 


function 
function 
function 
function 
function 
function 
function 
function 
function 
function 
function 
function 
function 
function 
function 
function 
function 
function 


SUBTYPE_INDICATION return boolean; 
ARRAY_TYPE DEFINITION return boolean; 

CHOICE return boolean; 

ITERATION SCHEME return boolean; 
LOOP_PARAMETER_ SPECIFICATION return boolean; 
EXPRESSION return boolean; 

RELATION return boolean; 

RELATION TAIL return boolean; 

SIMPLE EXPRESSION return boolean; 
SIMPLE_EXPRESSION TAIL return boolean; 

TERM return boolean; 

FACTOR return boolean; 

PRIMARY return boolean; 

CONSTRAINT return boolean; 

FLOATING OR_FIXED POINT CONSTRAINT return boolean; 
INDEX CONSTRAINT return boolean; 

RANGES return boolean; 

AGGREGATE return boolean; 


function COMPONENT ASSOCIATION return boolean; 
function ALLOCATOR return boolean; 

function NAME return boolean; 

function NAME TAIL return boolean; 

function LEFT PAREN NAME TAIL return boolean; 
function ATTRIBUTE DESIGNATOR return boolean; 
function INTEGER TYPE DEFINITION return boolean; 


function 
function 


DISCRETE RANGE return boolean; 
EXIT STATEMENT return boolean; 


2a 


function 
function 
function 
function 
function 


end PARSER_ 


RETURN STATEMENT return boolean 
GOTO_STATEMENT return boolean; 
DELAY STATEMENT return boolean; 
ABORT STATEMENT return boolean; 
RAISE STATEMENT return boolean; 
3; 
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aaeL TLE: ADAFLOW a 
-- MODULE NAME: PACKAGE PARSER 3 =o 
-- FILE NAME: PARSER3 .AD8 he 


-- DATE CREATED: 20 FEB 88 as 
-- LAST MODIFIED: 28 APR 88 a 


-- AUTHOR(S): LT ALBERT J. GRECCO, USN -- 


-- BASED ON A MODIFIED ADA GRAMMAR DEVELOPED BY: a 
== LCOR JEFFREY L. NIEDER, USN == 
=e LT KARL S. FAIRBANKS, JR., USN a 
== LCOR PAUL M. HERZIG, USN mir 


-- DESCRIPTION: This package implements the functions -- 
ea that make up the baseline productions for a top-down, = 
== recursive descent parser. Each function is preceded == 
=e by the grammar productions they are implementing. =< 


——FFSFSSSSSS SS SSS SS SSS SS SSS SSS SS SESS SSSSS SSS SSK SSS SES SSSSEsesSFE SS eesses __ 


with PARSER 4, TOKEN MATCHER, TOKEN SCANNER, CODE_BLOCKER, 
SYMBOL_TABLE, NET_GENERATOR; 


package body PARSER 3 is 
package TM renames TOKEN _MATCHER; 
package P4 renames PARSER 4; 


-- SUBTYPE_INDICATION --> NAME [CONSTRAINT ?] 
function SUBTYPE_INDICATION return boolean is 
begin 

if (P4.PRINT_CALLS) then 

P4.QUT_PUT("SUBTYPE_INDICATION"”); 


end if; 
if (NAME) then -- check for type_mark 
if (CONSTRAINT) then 
null; 
end if; 
return (TRUE); 
else 
return (FALSE); 
end if; 


end SUBTYPE_INDICATION; 


-- ARRAY_TYPE_DEFINITION --> (INDEX CONSTRAINT of SUBTYPE_INDICATION 
-- this function parses both constrained and unconstrained arrays 


Zo 


function ARRAY_TYPE_DEFINITION return boolean is 
begin 
if (P4.PRINT_CALLS) then 
P4.OUT PUT( "ARRAY TYPE DEFINITION"); 
end if; 
if (TM.MATCH(TM. TOKEN LEFT PAREN)) then 
if (INDEX CONSTRAINT) then 
if (TM.MATCH(TM. TOKEN OF)) then 
if (SUBTYPE_INDICATION) then 
return (TRUE); 


else 
P4.SYNTAX_ERROR( "Array definition"); 
end if; -- if subtype_indication 
else 
P4.SYNTAX_ERROR( "Array definition"); 
end if; -- if match(token_of) 
else 
P4.SYNTAX_ERROR( "Array definition”); 
end if; -- if index Constraint statement 
else 
return (FALSE); 
end if; -- if match(token_left_paren) 


end ARRAY_TYPE_DEFINITION; 
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-- CHOICE --> EXPRESSION [..SIMPLE EXPRESSION ?} 
oo --> EXPRESSION [CONSTRAINT ?] 
ce --> others 
function CHOICE return boolean is 
begin 
if (P4.PRINT_CALLS) then 
P4.OUT_PUTC CHOICE™): 
end if; 
if (EXPRESSION) then 
if (TM.MATCH(TM.TOKEN RANGE DOTS)) then -- check for discrete_range 
if (SIMPLE EXPRESSION) then 
null; 
else 
P4.SYNTAX_ERROR("Choice"); 
end if; -- if simple_expression statement 
elsif (CONSTRAINT) then 
null; 
end if; -- if match token_range dots 
return (TRUE); 
elsif (TM.MATCH(TM. TOKEN OTHERS)) then 
return (TRUE); 
else 
return (FALSE); 
end if; 
end CHOICE; 
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-- ITERATION_SCHEME --> while EXPRESSION 
-- --> for LOOP PARAMETER SPECIFICATION 
function ITERATION SCHEME return boolean is 
begin 
if (P4.PRINT CALLS) then 
P4.QUT_PUT( "ITERATION SCHEME") ; 
end if; 
if (TM.MATCH(TM. TOKEN WHILE)) then 
if (EXPRESSION) then 
return (TRUE); 
else 
P4.SYNTAX_ERROR( "Iteration scheme"); 
end if; 
elsif (T™™.MATCH(TM. TOKEN _FOR)) then 
if (LOOP PARAMETER SPECIFICATION) then 
return (TRUE); 
else 
P4.SYNTAX_ERROR( "Iteration scheme"); 
end if; 
else 
return (FALSE); 
end if; 
end ITERATION SCHEME ; 


-- LOOP_PARAMETER SPECIFICATION --> identifier in [reverse ?] DISCRETE_RANGE 
function LOOP_PARAMETER_SPECIFICATION return boolean is 
begin 
if (P4.PRINT_CALLS) then 
P4.QUT_PUT("LOOP_PARAMETER SPECIFICATION"); 
end if; 
if (TM.MATCH(TM.TOKEN_IDENTIFIER)) then 
if (TM.MATCH(TM.TOKEN_IN)) then 
if (TM.MATCH(TM. TOKEN _REVERSE)) then 
null; 
end if; -- if match(token_reverse) 
if (DISCRETE RANGE) then 
return (TRUE); 
else 
P4.SYNTAX_ERROR("Loop parameter specification"); 
end if; -- if discrete range statement 
else 
P4,SYNTAX_ERROR("“Loop parameter specif ication"); 
end if; -- if match(token_in) 
else 
retucn (FALSE); 


iol 


end if; -- if match(token_identifier) 
end LOOP_PARAMETER SPECIFICATION; 


-- EXPRESSION --> RELATION [RELATION _TAIL ?]} 
function EXPRESSION return boolean is 
begin 
if (P4.PRINT_ CALLS) then 
P4.0UT_PUT( "EXPRESSION" ); 
end if; 
if (RELATION) then 
if (RELATION TAIL) then 


null; 
end if; -- if relation_tail statement 
retucn (TRUE); 
else 
return (FALSE); 
end if; -- if relation statement 


end EXPRESSION; 


ry 


-- RELATION --> SIMPLE_EXPRESSION [SIMPLE_EXPRESSION_TAIL ?]} 
function RELATION return boolean is 
begin 
if (P4.PRINT_CALLS) then 
P4.QOUT_PUT( "RELATION" ); 
end if; 
if (SIMPLE_EXPRESSION) then 
if (SIMPLE EXPRESSION _TAIL) then 
null; 
end if; -- if simple_expression_tail statement 
return (TRUE); 
else 
return (FALSE); 


end if; -- if simple expression statement 
end RELATION; 
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-~- RELATION_TAIL --> [and [then ?] RELATION]* 
= --> [or [else ?] RELATION]* 
== --> [Exor RELATION]* 
function RELATION TAIL return boolean is 
begin 
if (P4.PRINT CALLS) then 
P4.OUT_PUT("RELATION TAIL"); 
end if; 
while (TM.MATCH(TM.TOKEN AND)) loop 
if (TM.MATCH( TM. TOKEN THEN)) then 
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null; 
end if; -- if match(token_then) 
if mot (RELATION) then 
P4.SYNTAX_ERROR( "Relation tail"); 
end if; -- if not relation statement 
end loop; 
while (TM.MATCH(TM.TOKEN_OR)) loop 
if (TM.MATCH(TM. TOKEN _ELSE)) then 
null; 
end if; -- if match(token_else) 
if not (RELATION) then 
P4.SYNTAX_ERROR("Relation tail"); 
end if; -- if not relation statement 
end loop; 
while (TM.MATCH(TM. TOKEN _XOR)) loop 
if not (RELATION) then 
P4.SYNTAX_ERROR("Relation tail"); 
end if; -- if not relation statement 
end loop; 
return (TRUE); 
end RELATION TAIL; 


-- SIMPLE EXPRESSION --> [+ ?] TERM [BINARY_ADDING_OPERATOR TERM]}* 
=e --> [- ?] TERM [BINARY ADDING OPERATOR TERM }* 
function SIMPLE_EXPRESSION return boolean is 
begin 
if (P4,.PRINT_ CALLS) then 
P4.QUT_PUT("SIMPLE_EXPRESSION” ); 
end if; 
if (TM.MATCH(TM. TOKEN PLUS) or TM.MATCH(TM.TOKEN_MINUS)) then 
if (TERM) then 
while (P4.BINARY ADDING OPERATOR) loop 
if not (TERM) then 
P4.SYNTAX_ERROR( "Simple expression"); 


end if; -- if not term statement 
end loop; 
return (TRUE); 
else 
P4.SYNTAX_ERROR( "Simple expression"); 
end if; -- if term statement 


elsif (TERM) then 
while (P4.BINARY ADDING OPERATOR) loop 
if not (TERM) then 
P4.SYNTAX_ERROR("Simple expression"); 
end if; -- if not term statement 
end toop; 
return (TRUE); 
else 
return (FALSE); 
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end if; -- if match(token_plus) et al statement 
end SIMPLE EXPRESSION; 


-- SIMPLE EXPRESSION_TAIL --> RELATIONAL_OPERATOR SIMPLE_EXPRESSION 
— --> [not ?] in RANGES 
-- --> [mot ?] in NAME 
function SIMPLE EXPRESSION_TAIL return boolean is 
begin 
if (P4.PRINT_CALLS) then 
P4,OUT_PUT("SIMPLE_ EXPRESSION TAIL"); 
end if; 
if (P4.RELATIONAL_OPERATOR) then 
if (SIMPLE_EXPRESSION) then 
return (TRUE); 


else 
P4,SYNTAX_ERROR( "Simple expression tail"); 
end if; -- if simple_expression statement 


elsif (TM.MATCH(TM. TOKEN _NOT)) then 
if (TM.MATCH(TM.TOKEN_IN)) then 
if (RANGES) then 
return (TRUE); 


elsif (NAME) then -- check for type_mark 
return (TRUE); 
else 
P4.SYNTAX_ERROR( "Simple expression tail”); 
end if; -- if ranges statement 
else 
P4.SYNTAX_ERROR("Simple expression tail"); 
end if; -- if match(token_in) statement 


elsif (TM.MATCH(TM.TOKEN_IN)) then 
if (RANGES) then 
return (TRUE); 


elsif (NAME) then -- check for type_mark 
return (TRUE); 
else 
P4.SYNTAX_ERROR( "Simple expression tail"); 
end if; -- if ranges statement 
else 
return (FALSE); 
end if; -- if relational operator statement 


end SIMPLE EXPRESSION TAIL; 


-- TERM --> FACTOR [MULTIPLYING OPERATOR FACTOR]* 
function TERM return boolean is 
begin 
if (P4.PRINT CALLS) then 
P4 OUT PUT ("TERM"); 
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end if; 
if (FACTOR) then 
while (P4.MULTIPLYING OPERATOR) loop 
if not (FACTOR) then 
P4.SYNTAX_ERROR("“Term"); 
end if; -- if not factor statement 
end loop; 
return (TRUE); 
else 
return (FALSE); 
end if; -- if factor statement 
end TERM; 


-- FACTOR --> PRIMARY [** PRIMARY ?] 
aS --> abs PRIMARY 
ae ~-> not PRIMARY 
function FACTOR return boolean is 
begin 
if (P4.PRINT_ CALLS) then 
P4.OUT_PUT("FACTOR"); 
end if; 
if (PRIMARY) then 
if (TM.MATCH(TM.TOKEN_EXPONENT)) then 
if (PRIMARY) then 


null; 
else 
P4.SYNTAX_ERROR("Factor"); 
end if; -- if primary statement 
end if; -- if match(token_exponent ) 


return (TRUE); 
elsif (™M.MATCH(TM.TOKEN ABSOLUTE)) then 
if (PRIMARY) then 
return (TRUE); 
else 
P4.SYNTAX_ERROR(“Factor"); 
end if; -~ if primary(abs) 
elsif (TM.MATCH(TM.TOKEN_NOT)) then 
if (PRIMARY) then 
return (TRUE); 


else 
P4.SYNTAX_ERROR("Factor"); 
end if; -- if primary(not) 
else 
return (FALSE); 
end if; -- if primary statement 


end FACTOR; 
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~-VPRIMARY ==> 
==> 
Sie 
“=> 
==) 
=> 
function PRIMARY 


Numeric_literal 
null 

string literal 
new ALLOCATOR 
NAME 

AGGREGATE 

return boolean is 


begin 


if (P4.PRINT_CALLS) then 
P4.QUT_PUT("PRIMARY") ; 


end if; 


if (TM.MATCH(TM. TOKEN NUMERIC _LITERAL)) then 


return (TRUE); 
elsif (TM.MATCH( TM 

return (TRUE); 
elsif (T™.MATCH(TM 

return (TRUE); 
elsif (TM.MATCH(TM 


.TOKEN_NULL)) then 
. TOKEN STRING LITERAL)) then 


.TOKEN_NEW)) then 


if (ALLOCATOR) then 


return (TRUE); 
else 


P4 - SYNTAX _ERROR( "Primary" ) : 


end if; 
elsif (NAME) then 
return (TRUE); 


-- if allocator statement 


elsif (AGGREGATE) then 


return (TRUE); 
else 
return (FALSE); 
end if; 
end PRIMARY; 


-- CONSTRAINT --> 
==) 
==> 
SP 
==> 
function CONSTRAINT 
begin 


-- if match(token_left_paren) 


range RANGES 

range <> 

digits FLOATING OR_FIXED POINT CONSTRAINT 
delta FLOATING OR_FIXED_POINT_CONSTRAINT 
(INDEX CONSTRAINT 


return boolean is 


if (P4.PRINT_CALLS) then 
P4.QUT_PUT( "CONSTRAINT" ); 


end if; 


if (TM.MATCH(TM.TOKEN RANGE)) then 


if (RANGES) then 
return (TRUE); 


elsif (TM.MATCH( 


return (TRUE); 


else 


TM. TOKEN BRACKETS)) then -- check for <> when parsing 
-- an unconstrained array 


P4.SYNTAX_ERROR("Constraint"); 
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end if; -- if ranges statement 
elsif (TM.MATCH(TM.TOKEN DIGITS)) or else (TM.MATCH(TM.TOKEN_DELTA)) then 
if (FLOATING OR FIXED POINT CONSTRAINT) then 
return (TRUE); 
else 
P4.SYNTAX_ERROR("Constraint"); 
end if; 
elsif (TM.MATCH(TM. TOKEN LEFT _PAREN)) then 
if (INDEX CONSTRAINT) then 
return (TRUE); 
else 
P4,.SYNTAX_ERROR( "Constraint" ); 
end if; 
else 
return (FALSE); 
end if; 
end CONSTRAINT; 
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-- FLOATING OR_FIXED_POINT_ CONSTRAINT --> SIMPLE EXPRESSION [range RANGES ? ]} 
function FLOATING OR_FIXED POINT CONSTRAINT return boolean is 
begin 
if (P4.PRINT CALLS) then 
P4.QUT_PUT("FLOATING OR_FIXED_POINT_ CONSTRAINT"); 
end if; 
if (SIMPLE EXPRESSION) then 
if (TM.MATCH(TM.TOKEN RANGE)) then 
if (RANGES) then 


null; 
else 
P4.SYNTAX_ERROR( “Floating or fixed point constraint”); 
end if; -- if ranges statement 
end if; -- if match(token_ range) 
return (TRUE); 
else 
return (FALSE); 
end if; -- if simple_expression statement 


end FLOATING _OR_ FIXED POINT CONSTRAINT; 
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-- INDEX CONSTRAINT --> DISCRETE_RANGE [, DISCRETE_RANGE]* ) 
function INDEX CONSTRAINT return boolean is 
begin 
if (P4.PRINT CALLS) then 
P4.QUT_PUT("INDEX_ CONSTRAINT"); 
end if; 
if (DISCRETE_RANGE) then 
while (TM.MATCH(TM.TOKEN COMMA)) loop 
if not (DISCRETE RANGE) then 
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P4.SYNTAX_ERROR( "Index constraint”); 
end if; -- if not discrete range 
end loop; 
if (TM.MATCH( TM. TOKEN _RIGHT_PAREN)) then 
return (TRUE); 


else 
P4.SYNTAX_ERROR("Index constraint"); 
end if; -- if match(token_right_paren) 
else 
return (FALSE); 
end if; -- if discrete_range statement 


end INDEX CONSTRAINT; 
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-- RANGES --> SIMPLE_EXPRESSION [..SIMPLE_EXPRESSION ?] 
function RANGES return boolean is 
begin 
if (P4.PRINT_CALLS) then 
P4.OUT_PUT( "RANGES" ) ; 
end if; 
if (SIMPLE_EXPRESSION) then 
if (TM.MATCH(TM. TOKEN RANGE DOTS)) then 
if (SIMPLE_EXPRESSION) then 
null; 
else 
P4.SYNTAX_ERROR( "Ranges" ) ; 
end if; -- if simple_expression statement 
end if; -- if match(token_range_ dots) 
return (TRUE); 
else 
return (FALSE); 
end if; -- if simple_expression statement 
end RANGES; 


-- AGGREGATE --> (COMPONENT ASSOCIATION [, COMPONENT ASSOCIATION]* ) 
function AGGREGATE return boolean is 
begin 
if (P4.PRINT CALLS) then 
P4.QUT_PUT( "AGGREGATE" ) ; 
end if; 
if (TM.MATCH( TM. TOKEN_LEFT PAREN)) then 
1f (COMPONENT ASSOCIATION) then 
while (TM.MATCH(TM. TOKEN _COMMA)) loop 
1f not (COMPONENT ASSOCIATION) then 
P4.SYNTAX_ERROR( "Aggregate" ); 
end if; -- if not component association 
end loop; 
vf (TM.MATCH( TM. TOKEN RIGHT PAREN)) then 
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return (TRUE); 
else 
P4.SYNTAX_ERROR( "Aggregate" ); 
end if; -- 1f match(token_right_paren) 
elise 
P4.SYNTAX_ERROR( "Aggregate" ); 
end if; -- if Component_association 
else 
return (FALSE); 
end if; -- if match(token_left_paren) 
end AGGREGATE; 
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-- COMPONENT ASSOCIATION --> [CHOICE [| CHOICE]* => ?] EXPRESSION 
function COMPONENT ASSOCIATION return boolean is 
begin 
if (P4.PRINT CALLS) then 
P4.QUT_PUT( "COMPONENT ASSOCIATION"); 
end if; 
if (CHOICE) then 
while (TM.MATCH(TM. TOKEN _BAR)) loop 
if not (CHOICE) then 
P4.SYNTAX_ERROR( "Component asociation"); 
end if; 
end loop; 
if (TM.MATCH(TM.TOKEN ARROW)) then 
if (EXPRESSION) then 
null; 
else 
P4.SYNTAX_ERROR( "Component asociation"); 
end if; -- if expression statement 
end if; -- if match(token_arrow) 
return (TRUE); 
else 
return (FALSE); 
end if; -- if choice statement 
end COMPONENT ASSOCIATION; 


-- ALLOCATOR --> SUBTYPE_INDICATION [ ‘AGGREGATE ?] 
function ALLOCATOR return boolean is 
begin 
if (P4.PRINT_ CALLS) then 
P4.QUT_PUT("ALLOCATOR"); 
end if; 
if (SUBTYPE INDICATION) then 
if (TM.MATCH( TM. TOKEN APOSTROPHE )) then 
if (AGGREGATE) then 
null; 
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else 
P4.SYNTAX_ERROR("Allocator”); 


end if; -- if aggregate statement 
end if; -- if match(token_apostrophe) 
return (TRUE); 
else 
return (FALSE); 
end if; -- if subtype_indication statement 


end ALLOCATOR; 


-- NAME --> identifier [NAME TAIL ?] 
=< --> character_literal [NAME_TAIL ?] 
-- --> string _literal [NAME TAIL ?] 
function NAME return boolean is 
SEARCH POINTER : SYMBOL_TABLE.SYM TAB_ACCESS; 


START_TOKEN > TOKEN_SCANNER. TOKEN _RECORD_TYPE; 
LOCATION_ONE : positive; 

LOCATION_TWO : positive; 

use SYMBOL TABLE; 

begin 


if (P4.PRINT_CALLS) then 
P4.QUT_PUT( "NAME" ); 
end if; 
if (TM.MATCH(TM.TOKEN_IDENTIFIER)) then 
TM.MATCHED_TOKEN(START_TOKEN); 
SEARCH POINTER := 
SYMBOL_TABLE.FIND_KEY(START_TOKEN.LEXEME(1..START_TOKEN.LEXEME SIZE)); 
if (NAME_TAIL) then 
null; 
elsif (TM.MATCH(TM.TOKEN _COLON)) then 
if (CODE BLOCKER.CURRENT_STATEMENT COUNT /= 0) then 
LOCATION ONE := CODE_BLOCKER.CURRENT_CODE_BLOCK_NUMBER; 
CODE _BLOCKER.EXIT_CODE BLOCK(START_TOKEN.SOURCE ) ; 
CODE_BLOCKER.ENTER CODE BLOCK(START_TOKEN.SOURCE, "LABELLED BLOCK") ; 
LOCATION TWO := CODE_BLOCKER.CURRENT CODE_BLOCK_NUMBER; 
CODE_BLOCKER. INCREMENT STATEMENT COUNT; 
NET_GENERATOR.CONNECT_BLOCKS(LOCATION_ONE, LOCATION_ TWO) ; 
else 
CODE BLOCKER .DELETE CODE BLOCK _ENTER; 
CODE _BLOCKER.ENTER_CODE BLOCK(START_TOKEN.SOURCE, "LABELLED BLOCK"); 
CODE_BLOCKER. INCREMENT STATEMENT COUNT; 
LOCATION_TWO := CODE _BLOCKER.CURRENT CODE BLOCK NUMBER; 
end if; 
if (SYMBOL_TABLE.FIND_KEY(START TOKEN.LEXEME(1.. 
START _TOKEN.LEXEME SIZE)) = null) then 
SYMBOL_TABLE.INSERT SYM TAB(START TOKEN. 
LEXEME(1..START TOKEN.LEXEME SIZE), 
SYMBOL TABLE.LABEL NAME, LOCATION TWO); 
else 
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SYMBOL_TABLE .UPDATE_SYM_TAB(LOCATION TWO) ; 
end if; 
return (FALSE); 
end if; 
return (TRUE); 
elsif (TM.MATCH(TM. TOKEN CHARACTER_LITERAL)) then 
if (NAME_TAIL) then 
null; 
end if; 
return (TRUE); 
elsif (TM.MATCH(TM. TOKEN STRING LITERAL)) then 
if (NAME_TAIL) then 
null; 
end if; 
return (TRUE); 
else 
return (FALSE); 
end if; 
end NAME; 


-- NAME_TAIL --> (LEFT PAREN _NAME_TAIL 
ae --> .SELECTOR [NAME_TAIL]* 
oe --> ‘AGGREGATE [NAME_TAIL]* 
- --> '‘ATTRIBUTE_DESIGNATOR [NAME_TAIL]* 
function NAME_TAIL return boolean is 
begin 
if (P4.PRINT CALLS) then 
P4.OUT_PUT("NAME_ TAIL"); 
end if; 
if (TM.MATCH(TM.TOKEN LEFT PAREN)) then 
SYMBOL_TABLE.SAVE_CURRENT_ENTRY; 
if (LEFT _PAREN_NAME_TAIL) then 
SYMBOL_TABLE .RESTORE_CURRENT_ENTRY; 
return (TRUE); 
else 
SYMBOL_TABLE.RESTORE CURRENT ENTRY; 
return (FALSE); 
end if; -- if left_paren_name_tail 
elsif (TM.MATCH(TM. TOKEN PERIOD)) then 
if (P4.SELECTOR) then 
while (NAME_TAIL) loop 
null; 
end loop; 
return (TRUE); 
else 
P4.SYNTAX_ERROR( "Name tail : expecting selector”); 
end if; -- if selector statement 
elsif (TM.MATCH(TM. TOKEN APOSTROPHE)) then 
SYMBOL _TABLE.SAVE CURRENT ENTRY; 
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if (AGGREGATE) then 
while (NAME_TAIL) loop 
null; 
end loop; 
SYMBOL_TABLE.RESTORE_CURRENT_ENTRY; 
return (TRUE); 
elsif (ATTRIBUTE DESIGNATOR) then 
while (NAME _TAIL) loop 
null; 
end loop; 
SYMBOL_TABLE.RESTORE CURRENT _ENTRY; 
return (TRUE); 


else 
P4.SYNTAX_ERROR("Name tail : expecting aggregate or attribute”); 
end if; -- if aggregate statement 
else 
return (FALSE); 
end if; -- if match(token_left_paren) 


end NAME_TAIL; 


-- LEFT_PAREN_NAME_TAIL --> [FORMAL_PARAMETER ?] EXPRESSION [..EXPRESSION ?] 
a [, [FORMAL_PARAMETER ?] EXPRESSION [..EXPRESSION ?]]* 
Se ) [NAME_TAIL]* 
function LEFT PAREN _NAME_TAIL return boolean is 
begin 
if (P4.PRINT_ CALLS) then 
P4.QUT_PUT("LEFT PAREN_NAME_TAIL"); 


end if; 

if (P4.FORMAL_ PARAMETER) then -- check for optional formal parameter 
null; -- before the actual parameter 

end if; -- if formal parameter statement 


if (EXPRESSION) then 
if (TM.MATCH(TM. TOKEN RANGE DOTS)) then 
if not (EXPRESSION) then 
P4.SYNTAX_ERROR( "Left paren name tail"); 
end if; -- if not expression statement 
end if; -- if match(token_range dots) 
while (TM.MATCH( TM. TOKEN COMMA)) loop 
if (P4.FORMAL_ PARAMETER) then 
null; 
end if; -- if formal_parameter statement 
if not (EXPRESSION) then 
P4.SYNTAX_ERROR( "Left paren name tail"); 
end if; -- if not expression statement 
if (TM.MATCH(TM.TOKEN RANGE DOTS)) then 
if not (EXPRESSION) then 
P4.SYNTAX_ERROR( "Left paren name tail"); 
end if; -- 1f not expression statement 
end if; -- if match(token range dots) 
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end loop; 
if (TM.MATCH(TM.TOKEN RIGHT PAREN)) then 
while (NAME_TAIL) loop 
null; 
end loop; 
return (TRUE); 
else 
return (FALSE); 
end if; -- if match( token_right_paren) 
elsif (DISCRETE RANGE) then 
if (TM.MATCH(TM. TOKEN RIGHT PAREN)) then 
while (NAME_TAIL) loop 
null; 
end loop; 
return (TRUE); 
else 
P4.SYNTAX_ERROR("Left paren name tail"); 
end if; 
else 
return (FALSE); 
end if; -- if match(token_right_paren) 
end LEFT _PAREN_NAME_ TAIL; 
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-- ATTRIBUTE DESIGNATOR --> identifier [(EXPRESSION) ?] 
oe --> range [(EXPRESSION) ?] 
=> --> digits [(EXPRESSION) ?] 
ae --> delta [(EXPRESSION) ?] 
function ATTRIBUTE DESIGNATOR return boolean is 
begin 
if (P4.PRINT_CALLS) then 
P4.QUT_PUT("ATTRIBUTE DESIGNATOR"); 
end if; 
if (TM.MATCH(TM.TOKEN_IDENTIFIER)) or else (TM.MATCH( TM. TOKEN _RANGE)) then 
if (TM.MATCH(TM.TOKEN LEFT PAREN)) then 
if (EXPRESSION) then 
if (TM.MATCH( TM. TOKEN RIGHT PAREN)) then 


null; 
else 
P4.SYNTAX_ERROR( "Attribute designator"); 
end if; -- if match(token_right_paren) 
else 
P4.SYNTAX_ERROR( "Attribute designator"); 
end if; -- if expression statement 
end if; -- if matcn(token_left_paren) 


return (TRUE); 
elsif (TM.MATCH(TM.TOKEN DIGITS)) or else (TM.MATCH(TM. TOKEN DELTA)) then 
if (TM.MATCH(TM.TOKEN LEFT PAREN)) then 
1f (EXPRESSION) then 
if (TM.MATCH( TM. TOKEN RIGHT PAREN)) then 
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null; 


else 
P4.SYNTAX_ERROR( “Attribute designator"); 
end if; -- if match(token_right_paren) 
else 
P4.SYNTAX_ERROR( "Attribute designator"); 
end if; -- if expression statement 
end if; -- if match(token_left_paren) 
return (TRUE); 
else 
return (FALSE); 
end if; -- if match(token_identifier) 


end ATTRIBUTE_DESIGNATOR; 


-- INTEGER_TYPE_DEFINITION --> range RANGES 
function INTEGER TYPE DEFINITION return boolean is 
begin 

if (P4.PRINT_CALLS) then 

P4.OUT_PUT("INTEGER_TYPE_ DEFINITION"); 
end if; 
if (TM.MATCH(TM.TOKEN RANGE)) then 
if (RANGES) then 
return (TRUE); 
else 
P4.SYNTAX_ERROR( "Integer type definition"); 
end if; 
else 
return (FALSE); 

end if; 

end INTEGER TYPE DEFINITION; 


-- DISCRETE_RANGE --> RANGES [CONSTRAINT ?] 
function DISCRETE RANGE return boolean is 
begin 

if (P4.PRINT CALLS) then 

P4.QUT_PUT("DISCRETE RANGE"); 
end if; 

if (RANGES) then 

if (CONSTRAINT) then 


null; 
end if; -- if constraint statement 
return (TRUE); 
else 
return (FALSE): 
end if; -- if ranges statement 


end DISCRETE RANGE: 
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~- EXIT_STATEMENT --> [NAME ?} [when EXPRESSION ?] ; 
function EXIT_STATEMENT return boolean is 
begin 
if (P4.PRINT_ CALLS) then 
P4.QUT_PUT("EXIT_STATEMENT"); 
end if; 
if (NAME) then 
null; 
end if; -- if name statement 
if (TM.MATCH(TM. TOKEN WHEN)) then 
if (EXPRESSION) then 


null; 
else 
P4.SYNTAX_ERROR( “Exit statement"); 
end if; -- if expression statement 
end if; -- if match(token_when) 


if (TM.MATCH(TM. TOKEN SEMICOLON)) then 
return (TRUE); 
else 
return (FALSE); 
end if; -- if match(token_semicolon) 
end EXIT_STATEMENT; 


-- RETURN_STATEMENT --> [EXPRESSION ?]} ; 
function RETURN_STATEMENT return boolean is 
begin 

1f (P4.PRINT_CALLS) then 

P4.OUT_PUT("RETURN_STATEMENT"); 
end if; 

if (EXPRESSION) then 

null; 

end if; 

if (TM.MATCH(TM.TOKEN_SEMICOLON)) then 

return (TRUE); 

else 

return (FALSE); 

end if; 

end RETURN STATEMENT; 


-- GOTO_STATEMENT --> NAME ; 
function GOTO_STATEMENT return boolean is 
START_TOKEN : TOKEN SCANNER. TOKEN _RECORD_TYPE; 
LOCATION ONE : positive; 
use SYMBOL TABLE; 
begin 
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if (P4.PRINT CALLS) then 
P4.QUT_PUT("GOTO_STATEMENT"); 
end if; 
if (NAME) then 
TM.MATCHED TOKEN(START_TOKEN); 
if (SYMBOL_TABLE.FIND KEY(START_TOKEN.LEXEME(1..START_TOKEN.LEXEME_SIZE)) 
= null) then 
SYMBOL_TABLE.INSERT_SYM_TAB(START_TOKEN.LEXEME(1..START_TOKEN. 
LEXEME SIZE),SYMBOL_TABLE.LABEL_NAME, 0); 
end if; 
LOCATION_ONE := CODE_BLOCKER.CURRENT_CODE_BLOCK_NUMBER; 
NET GENERATOR .GO_TO(LOCATION_ONE, 
SYMBOL_TABLE.FIND_KEY(START_TOKEN.LEXEME(1..START_TOKEN.LEXEME_SIZE))); 
CODE_BLOCKER. INCREMENT STATEMENT COUNT; 
CODE BLOCKER.EXIT_CODE_BLOCK( START_TOKEN.SOURCE) ; 
COOE_BLOCKER.ENTER_CODE_ BLOCK(START_TOKEN.SOURCE, ""); 
if (TM.MATCH(TM. TOKEN SEMICOLON)) then 
return (TRUE); 


else 
P4.SYNTAX_ERROR( "Goto statement"); 
end if; -- if match(token_semicolon) 
else 
return (FALSE); 
end if; -- if name statement 


end GOTO_STATEMENT; 


-- DELAY_STATEMENT -~> SIMPLE EXPRESSION ; 
function DELAY_STATEMENT return boolean is 
begin 

if (P4.PRINT_CALLS) then 

P4.QUT_PUT( "DELAY STATEMENT"); 
end if; 
if (SIMPLE_EXPRESSION) then 
if (TM.MATCH(TM. TOKEN SEMICOLON)) then 
return (TRUE); 


else 
P4.SYNTAX_ERROR("Delay statement"); 
end if; -- if match(token_semicolon) 
else 
return (FALSE); 
end if; -- If simple_expresston statement 


end DELAY STATEMENT; 


-- ABORT STATEMENT --> NAME [, NAME ]* ; 
function ABORT STATEMENT return boolean is 
begin 

Tf (P47 PRINT (CALLS) then 
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P4.QUT_PUT( "ABORT STATEMENT”); 
end if; 
if (NAME) then 
while (TM.MATCH( TM. TOKEN COMMA)) loop 
if not (NAME) then 
P4.SYNTAX_ERROR( "Abort statement"); 
end if; 
end loop; 
if (TM.MATCH(TM. TOKEN _SEMICOLON)) then 
return (TRUE); 


-- if not name statement 


else 
P4.SYNTAX_ERROR( "Abort statement"); 
end if; -- if match(token_semicolon) 
else 
return (FALSE); 
end if; -- if name statement 


end ABORT_STATEMENT; 


~- RAISE_STATEMENT --> [NAME ?] ; 
function RAISE STATEMENT return boolean is 
begin 
if (P4.PRINT_CALLS) then 
P4.Q0UT_PUT( "RAISE STATEMENT"); 
end if; 
if (NAME) then 
null; 
end if; 
if (T™M.MATCH(TM.TOKEN SEMICOLON)) then 
return (TRUE); 
else 
return (FALSE); 
end if; 
end RAISE STATEMENT; 


end PARSER 3; 
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=>. a TEE: ADAF LOW cs 


-- MODULE NAME: PACKAGE PARSER 4 == 
-- FILE NAME: PARSER4.ADS oo 


-- DATE CREATED: 20 FEB 88 es 
-- LAST MODIFIED: 28 APR 88 ae 


-- AUTHOR(S): LT ALBERT J. GRECCO, USN -- 


-- BASED ON A MODIFIED ADA GRAMMAR DEVELOPED BY: ier 
ae LCDR JEFFREY L. NIEDER, USN = 
== LT KARL S. FAIRBANKS, JR., USN <= 
a LCDR PAUL M. HERZIG, USN 2 


-- DESCRIPTION: This package defines the functions that a 


= are the lowest level productions for a top-down, a 
ac recursive descent parser. -- 


—~— SSSSSSSSSSSSSSSSSSS SHES SST SESSSSSSSSSSSFS SSS SSSSSSSSSSSSSSVSIsVSESssess 


with TEXT_IO, TOKEN MATCHER; 

package PARSER 4 is 
PRINT_CALLS : boolean := FALSE; 
PARSER _ERROR : exception; 
function MULTIPLYING OPERATOR return boolean; 
function BINARY_ADDING OPERATOR return boolean; 
function RELATIONAL_OPERATOR return boolean; 
function ENUMERATION_TYPE DEFINITION return boolean; 
function ENUMERATION LITERAL return boolean; 
function FORMAL_PARAMETER return boolean; 
function SELECTOR return boolean; 
procedure SYNTAX_ERROR(ERROR_ MESSAGE : in string); 


procedure OUT PUT(FUNCTION_NAME : in string); 


end PARSER 4; 
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——FSFSSFFSSSF SSS SSS SFSSSFSFSFSSFFFFFSSS SFT SF SSSSSSFSSFSFSF SES SS SSESSsEsEV Esse ses. 


ae TL LE: ADAFLOW ie 
-- MODULE NAME: PACKAGE PARSER_4 ae 
-- FILE NAME. PARSER4 .ADB Se 


-- DATE CREATEO: 20 FEB 88 == 
-- LAST MODIFIED: 28 APR 88 oi 


-- AUTHOR(S): LT ALBERT J. GRECCO, USN -- 


-- BASEO ON A MOOIFIEO AOA GRAMMAR OEVELOPEO BY: == 
a LCOR JEFFREY L. NIEDER, USN == 
aS LT KARL S. FAIRBANKS, JR., USN == 
== LCOR PAUL M. HERZIG, USN a 


-- OESCRIPTION: This package implements functions that == 
=< are the lowest level productions for a top-down, == 
ao recursive descent parser. Each function is preceded ai 
i by the grammar productions they are implementing. a 


PPELEEEPE EEE EE SEE SEE SESE ER ESE SESE SESE SEES SEE SESE ES ESSE SESE SE SES ES ETE SS 


with TOKEN MATCHER, TOKEN SCANNER, TEXT_IO, SYMBOL_TABLE; 


package body PARSER 4 is 
package TM renames TOKEN _MATCHER; 


BeeMULTIPLYING_OPERATOR --> * 
== Spy 7) 
ei --> mod 
= --> rem 
function MULTIPLYING OPERATOR return boolean is 
begin 
if (PRINT _CALLS) then 
OUT_PUT( "MULTIPLYING OPERATOR"); 
end if; 
if (TM.MATCH(TM. TOKEN _ASTERISK)) then 
return (TRUE); 
elsif (TM.MATCH(TM. TOKEN SLASH)) then 
return (TRUE); 
elsif (TM.MATCH( TM. TOKEN _MOD)) then 
return (TRUE); 
elsif (TM.MATCH(TM.TOKEN_REM)) then 
return (TRUE); 
else 
return (FALSE); 
end if; 
end MULTIPLYING OPERATOR; 
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-- BINARY_ADDING OPERATOR --> + 
J ~-> = 
== ==> & 
function BINARY ADDING OPERATOR return boolean is 
begin 
if (PRINT CALLS) then 
OUT _PUT("BINARY ADDING OPERATOR"); 
end if; 
if (TM.MATCH(TM.TOKEN_PLUS)) then 
return (TRUE); 
elsif (TM.MATCH(TM.TOKEN MINUS)) then 
return (TRUE); 
elsif (TM.MATCH(TM.TOKEN_AMPERSAND)) then 
return (TRUE); 
else 
return (FALSE); 
end if; 
end BINARY ADDING OPERATOR; 


— eee ee em ww oe ee ee = et ee ee we = = & = = = = = = = = = = = = = = = = = = = = = = oe ee ee ow ee = ee ee ee ee ee ee ee 


~- RELATIONAL_OPERATOR --> 
== --)> /= 
=— == 
3S = ane = 
== == 
=e Say Se 
function RELATIONAL OPERATOR return boolean is 
begin 
if (PRINT CALLS) then 
OUT _PUT( "RELATIONAL OPERATOR" ); 
end if; 
if (TM.MATCH( TM. TOKEN _EQUALS)) then 
return (TRUE); 
elsif (TM.MATCH(TM. TOKEN NOT _EQUALS)) then 
return (TRUE); 
elsif (TM.MATCH(TM.TOKEN_LESS THAN)) then 
return (TRUE); 
elsif (TM.MATCH(TM.TOKEN LESS THAN_EQUALS)) then 
return (TRUE); 
elsif (TM.MATCH( TM. TOKEN _GREATER_THAN)) then 
return (TRUE); 
elsif (TM.MATCH(TM. TOKEN GREATER THAN EQUALS)) then 
return (TRUE); 
else 
return (FALSE); 
end if; 
end RELATIONAL OPERATOR; 
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-- ENUMERATION TYPE_DEFINITION --> (ENUMERATION LITERAL 
a {, ENUMERATION LITERAL ]*) 
function ENUMERATION_TYPE_DEFINITION return boolean is 
begin 
if (PRINT_CALLS) then 
OUT _PUT("ENUMERATION_TYPE_ DEFINITION"); 
end if; 
if (7M.MATCH(TM.TOKEN_LEFT_PAREN)) then 
if (ENUMERATION_ LITERAL) then 
while (TM.MATCH(TM.TOKEN_COMMA)) loop 
if not (ENUMERATION_LITERAL) then 
SYNTAX_ERROR("Enumeration type def inition"); 
end if; -- if not enumeration_literal 
end loop; 
if (TM.MATCH(TM. TOKEN _RIGHT_PAREN)) then 
return (TRUE); 


else 
SYNTAX_ERROR( “Enumeration type definition"); 
end if; -- if match(token_right_paren) 
else 
SYNTAX_ERROR( "Enumeration type definition”); 
end if; -- if enumeration_literal statement 
else 
return (FALSE); 
end if; -- if match(token_left_paren) 


end ENUMERATION_TYPE_ DEFINITION; 


-- ENUMERATION_LITERAL --> identifier 
5 --> character_literal 
function ENUMERATION LITERAL return boolean is 
begin 
if (PRINT _CALLS) then 
OUT _PUT("ENUMERATION_ LITERAL"); 
end if; 
if (TM.MATCH(TM.TOKEN_IDENTIFIER)) then 
return (TRUE); 
elsif (TM.MATCH(TM. TOKEN CHARACTER_LITERAL)) then 
return (TRUE); 
else 
return (FALSE); 
end if; 
end ENUMERATION LITERAL; 


-~- FORMAL PARAMETER --> identifier => 
function FORMAL PARAMETER return boolean is 


Lol 


PEEK AHEAD TOKEN : TOKEN SCANNER. TOKEN_RECORD_TYPE; 


TEST_TOKEN : TOKEN SCANNER.TOKEN RECORD_TYPE; 
use TOKEN SCANNER; 
begin 


if (PRINT_CALLS) then 
OUT_PUT( “"FORMAL_PARAMETER” ) ; 
end if; 


TEST_TOKEN.LEXEME := (others => ' '); 
TEST_TOKEN.LEXEME(1..2) := "=>"; 
TEST_TOKEN.LEXEME SIZE := 2; 


TEST TOKEN. TOKEN TYPE := TOKEN SCANNER.DELIMITER; 
TM.NEXT_TOKEN(PEEK_AHEAD_TOKEN); 
if (PEEK_AHEAD_TOKEN = TEST_TOKEN) then 
if (TM.MATCH(TM.TOKEN _IDENTIFIER)) then 
if (TM.MATCH(TM. TOKEN ARROW)) then 
return (TRUE); 
else 
SYNTAX_ERROR( “Formal parameter"); 
end if; 
else 
SYNTAX_ERROR( "Formal parameter" ); 
end if; 
else 
return (FALSE); 
end if; 
end FORMAL_PARAMETER; 


-- if match({ token_arrow) 


-- if match(token_identifier) 


== SELECTOR -=> 
==> 
==) 
==> 
function SELECTOR 
SEARCH POINTER : 
SEARCH_TOKEN 
use SYMBOL TABLE; 
begin 


identifier 
character_literal 
string literal 
all 
return boolean is 


SYMBOL_TABLE.SYM_TAB_ACCESS; 
: TOKEN SCANNER. TOKEN RECORD_TYPE; 


if (PRINT CALLS) then 
OUT_PUT("SELECTOR"); 


end if; 


if (TM.MATCH( TM. 


TOKEN IDENTIFIER)) then 


TM .MATCHED_TOKEN( SEARCH_TOKEN); 


SEARCH POINTER 


>= SYMBOL_TABLE.RETRIEVE SYM; 


if (SEARCH POINTER /= null) then 


SEARCH_POINTER := 


end if; 


SYMBOL_TABLE.SELECT_COMPONENT(SEARCH_TOKEN. 
LEXEME(1..SEARCH TOKEN.LEXEME SIZE)); 


return (TRUE); 
elsif (TM.MATCH(TM. TOKEN CHARACTER LITERAL)) then 
return (TRUE); 
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elsif (TM.MATCH( TM. TOKEN STRING _LITERAL)) then 
return (TRUE); 

elsif (TM.MATCH(TM.TOKEN ALL)) then 
return (TRUE); 

else 
return (FALSE); 

end if; 

end SELECTOR; 


procedure SYNTAX_ERROR(ERROR_MESSAGE : in string) is 
begin 
TEXT_I10.new_line(2); 
TEXT_I0.put("Incomplete "); 
TEXT_10.put(ERROR_MESSAGE ) ; 
TEXT_10.put(" at line number "); 
TEXT_10.put(positive' IMAGE(TM.LINES CHECKED) ); 
TEXT_I0.new_line(2); 
raise PARSER ERROR; 
end SYNTAX_ERROR; 


procedure OUT _PUT(FUNCTION NAME : in string) is 
TOP_TOKEN : TOKEN SCANNER.TOKEN_RECORD_TYPE; 
use TEXT_I0O, TOKEN_SCANNER; 
begin 
TOKEN _MATCHER.CURRENT_TOKEN( TOP_TOKEN); 
put(FUNCTION_NAME); set_col( 40); 
if (TOP_TOKEN.TOKEN TYPE /= TOKEN _SCANNER.EOF) then 
for LEXEME_INDEX in 1..TOP_TOKEN.LEXEME SIZE loop 
put( TOP_TOKEN.LEXEME(LEXEME_INDEX)); 
end loop; 
end if; 
new_line; set_col(40); 
put_line( TOKEN SCANNER. TOKEN CLASS'IMAGE( TOP_TOKEN. TOKEN _TYPE)); 
end OUT_PUT; 


end PARSER 4; 
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APPENDIX D 
“ADAFLOW” PROGRAM LISTING - NET GENERATOR 


~~ SSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSHSSSSSSSSSSASSSSASSASASSAS*s#SVss*esMe_ 


==. -T PRE: ADAF LOW = 


-- MODULE NAME: PACKAGE NET_GENERATOR = 
-- FILE NAME: NET.AOS oa 


-- “PATE CREATED: 12 MAR 88 a5 
-- LAST MODIFIED: 28 APR 88 ae 


-- AUTHOR(S): LT ALBERT J. GRECCO, USN == 


-- DESCRIPTION: This package contains the procedures which = 
a define the interface to the net generator. =F 


—K—SFSSSSSSSSSSSSSSSSSSSSSSSKSSSSSSSTSSSSSSSSSSHESRSESSSSSHPSSESRSSPSSVSVPSsSs se. 


with SYMBOL_TABLE; 
package NET_GENERATOR is 
NET GENERATOR OVERFLOW : exception; 


procedure START(RUN_UNIT_NAME : in SYMBOL_TABLE.SYM_TAB_ACCESS); 
-- post - Defines a either a subprogram place or task place that has 
5 an initial marking in the petri net model. 


procedure DECISION START(START_PLACE : in positive; 

END_PLACE : in SYMBOL_TABLE.SYM_TAB_ACCESS); 
-- post - Defines a place that is the root place of a multi-way decision 
sa path and it's corresponding end label. 


procedure DECISION OR(END_PATH PLACE : in positive); 

-- post - Ends the current path of a multi-way decision and starts the 
== next path. The decision start place is reactivated as the 
= current block number. 


procedure EXPLICIT DECISION OR; 

-- post - Ends the current path of a multi-way decision and starts the 
a next path. The decision start place is reactivated as the 
== current block number. 
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procedure 
post - 


procedure 
aapost - 


procedure 
-- pre - 
pe: - 
procedure 
-- pre - 
me: . 
procedure 
post - 


procedure 


-- post - 


procedure 
-- post - 


procedure 


apOSt = 


procedure 


SampOSt — 


procedure 


-- post - 


procedure 
mePOSt, = 


ENO_DECISION(END_PATH_PLACE 
Ends the current path of a multi-way decision and terminates 
the multi-way decision. 


in positive); 


EXPLICIT _END DECISION; 
Ends the current path of a multi-way decision and terminates 
the multi-way decision. 


CALL(CURRENT_LOCATION in positive; 

PROCEOURE_LOCATION in SYMBOL_TABLE.SYM_TAB_ACCESS) ; 
The procedure location must be the current entry in the 
symbol table. 
The abstract grammar for a procedure call is generated. 
ENTRY _CALL(CURRENT_ LOCATION : in positive; 

ENTRY LOCATION in SYMBOL_TABLE.SYM_TAB_ACCESS); 

The entry location must be the current entry in the 
symbol table. 
The abstract grammar for a task entry iS generated. 


TASK_ACCEPT(CURRENT_LOCATION in positive; 
ENTRY LOCATION in positive); 
The abstract grammar for a task accept is generated. 


END_ACCEPT( CURRENT LOCATION in positive; 

ENTRY_END in positive); 
The abstract grammar for the end of an accept statement is 
generated. 


EXPLICIT _END_ACCEPT(ENTRY_END : 
The abstract grammar for the end of an accept statement is 
generated. 


in positive); 


GO_TO(CURRENT_LOCATION : in positive; 
GO_TO_LOCATION in SYMBOL_TABLE.SYM_TAB_ACCESS); 
The abstract grammar for a goto statement is generated. 


END_LOOP(ENO_ LOCATION : in positive; 
LOOP_START in SYMBOL_TABLE.SYM_TAB_ACCESS) ; 
The abstract grammar for a loop is generated. 


CONNECT BLOCKS( CURRENT LOCATION In positive; 
NEXT_LOCATION in positive); 

used to explicitly declare a transition between two known 

code blocks. The abstract grammar for a transition between 


two petri net places is generated. 


EXPLICIT END(NEXT LOCATION 
The current forest is terminated and a new forest 1s begun. 


in positive); 
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procedure TRANSLATE_TO_PEANUT; 

-- post - used to translate the abstract petri net grammar to a 

as text file used as an input file to P-NUT petri net analyzer. 

ao Produces two files: 1) a.out - P-NUT input file 

== 2) place.dat - text file that describes all 
= the places that exist in the 
<< petri net and/or the 

= places relation to the 

as original source code. 

=< The net generator and code blocker are reset to their 

== initial states. 


procedure RESET_NET_GENERATOR; 
-- post - The net generator is returned to it's initial state. 


end NET GENERATOR; 


156 


——- SFFSFSSSSSSSSSSSSSSSFSSSSSS SSS SSSESSESSSSSSE SSE SSS SSS SSS SSS SSS sSFE SESE sEs ses _. 


-- TITLE: ADAF LOW -- 
-- MODULE NAME: —§ PACKAGE NET GENERATOR -- 
-- FILE NAME: NET. ADB -- 


-- DATE CREATED: 12 MAR 88 == 
-- LAST MODIFIED: 28 APR 88 == 


-- AUTHOR(S): LT ALBERT J. GRECCO, USN ao 


-- DESCRIPTION: This package contains the procedures which == 
aa implement the interface to the net generator. -- 


-- -- 


~— SFSFSSSSTSSTSSSSSTS SSS SST SSS SS SSSSSESSSESSSSSSS SSS SSS SSSESSSESSsSssesseseseseses_. 


with TOKEN SCANNER, 
GENERIC_LIST, 
GENERIC_STACK, 
UNCHECKED_DEALLOCATION, 
SYMBOL_TABLE, 
CODE_BLOCKER, 
TEXT_IO, 
10_EXCEPTIONS; 


package body NET_GENERATOR jis 
DUMMY SOURCE : TOKEN SCANNER.SOURCE_RECORD; 
type PETRI_IDENTIFIER_ TYPE is (PLACE, TRANSITION); 


type LIST_NODE is 


record 
PETRI_TAG : PETRI_IDENTIFIER_ TYPE, 
SYMBOL : SYMBOL_TABLE.SYM_TAB_ACCESS := nul}; 


end record; 
type LIST_NODE_POINTER is access LIST_NODE; 


package NEST STACK is new GENERIC _STACK(LIST NODE POINTER); 
NS : NEST STACK.STACK; 


TRANSITION POINTER : LIST _NODE_POINTER; 
DECISION ROOT : LIST NODE POINTER : 
DECISION_TAIL : LIST_NODE_POINTER : 


null; 


null; 
package ABSTRACT _SYNTAX_LIST 1s 


type LIST_INSTANCE is private; 
type LIST 1s access LIST_ INSTANCE; 
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LIST OVERFLOW : exception; 
LIST_UNDERFLOW : exception; 


-- Operations: If the list is not empty, then one of the nodes is designated 
as as the current node. Ocaasionally, in the postcondition, it 1S necessary 
aie to refer to the list of the current node as they were immediately before 
= execution of the operation. L-pre and c-pre, respectively, are employed 
-- for these references. 


procedure FIND _FIRST(L : in out LIST); 

-- pre - The list L is not empty. 

-- post - The first node is the current node. 

-- exceptions raised - LIST_UNDERFLOW if L is empty. 


procedure FIND _NEXT(L : in out LIST); 

-- pre - The list L is not empty and the last node is not the current node. 
-- post - c-next in L is the current node. 

-- exceptions raised - LIST_UNDERFLOW if L is empty. 

aa - LIST_OVERFLOW if the last node is the current node. 


procedure FIND _PREVIOUS(L : in out LIST); 
-- pre - fhe list L is not empty and the first node is not the current node. 
-- post - c-prior in L is the current node. 

-- exceptions raised - LIST_UNDERFLOW if L is empty or c is the first node. 


procedure FIND_LAST(L : in out LIST); 

-- pre - The list L iS not empty. 

-- post - The last node in L is the current node. 

-- exceptions raised - LIST_UNDERFLOW if L is empty. 


procedure RETRIEVE(L : in LIST; ITEM : out LIST_NODE_ POINTER); 

-- pre - The list L is not empty. 

-- post - ITEM contains the value of the element in the current node. 
-- exceptions raised - LIST_UNDERFLOW if L is empty. 


procedure UPDATE(L : in out LIST; ITEM : in LIST_NODE_POINTER); 
-- pre - The list L is not empty. 

-- post - The current node in L contains ITEM as its element. 
-- exceptions raised - LIST_UNDERFLOW if L is empty. 


procedure INSERT(L : in out LIST; ITEM : in LIST NODE POINTER); 

-- pre - The number of nodes in L has not reached its bound. 

-- post - A node containing ITEM is the last node in the list, and the last 
sp node in L-pre, if any, is its predecessor. The node containing 
as ITEM is the current node. 

-- exceptions raised - LIST OVERFLOW if L has reached its bound. 


procedure DELETE(L : in out LIST); 


pre - The list L iS not empty. 
- post - c-pre in not in the list L. If c-pre was the first node, 
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os then c-next, if it exists, is the successor of c-prior. If the 
== list L is not empty, then the last node is the current node. 
-- exceptions raised - LIST_UNDERFLOW if L is empty. 


function SIZE_OF(L : in LIST) return natural; 
-- post - SIZE_OF is the number of nodes in list L. 


function EMPTY(L : in LIST) return boolean; 
-- post - If the list L has no nodes then EMPTY is true, else EMPTY is 
= false. 


function FULL(L : in LIST) return boolean; 
-- post - If the number of nodes in the list L has reached the maximum 
== allowed, then FULL is true, else FULL is false. 


function FIRST(L : in LIST) return boolean; 

-- pre - The list L is not empty. 

-- post - If the first node is the current node in L then FIRST is true, else 
=- FIRST is false. 

-- exceptions raised - LIST_UNDERFLOW if L is empty. 


function LAST(L : in LIST) return boolean; 

-- pre - The list L is not empty. 

-- post - If the last node is the current node in L then LAST is true, else 
-- LAST is false. 

-- exceptions raised - LIST_UNDERFLOW if L is empty. 


procedure CREATE(L : in out LIST; SUCCESS : out boolean); 
-- post - If a list L can be created then L exists and is empty, and SUCCESS 
-- is TRUE else SUCCESS is FALSE. 


procedure DISPOSE(L : in out LIST); 
-- post - L-pre does not exist. 


private 
type NODE; 


type NODE POINTER is access NODE; 
type NODE is 


record 
ELEMENT : LIST_NODE_ POINTER; 
NEXT : NODE_POINTER; 


end record; 
type LIST_INSTANCE is 


record 
HEAD : NODE POINTER := null; 
TAIL : NODE POINTER := null; 
CURRENT : NODE POINTER := null; 
SIZE | nMatugal <= 0; 


end record; 
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end ABSTRACT_SYNTAX_LIST; 
package FOREST LIST is new GENERIC_LIST(ABSTRACT SYNTAX _LIST.LIST); 
FOREST * FOREST_UETS(TEYSt: 


START_SYNTAX : ABSTRACT _SYNTAX_LIST.LIST; 
STOP_PLACES : ABSTRACT_SYNTAX_LIST.LIST; 


package body ABSTRACT _SYNTAX_LIST is 


procedure FREE_NODE is new UNCHECKED DEALLOCATION(NODE, NODE_POINTER); 

procedure FREE_LIST is new UNCHECKED DEALLOCATION(LIST_INSTANCE, LIST); 

procedure FREE_SYM_REC is new UNCHECKED DEALLOCATION( SYMBOL_TABLE. 
SYM_TAB_RECORD, 
SYMBOL_TABLE. 
SYM_TAB_ACCESS); 


procedure FIND _FIRST(L : 1n out LIST) is 
-- pre - The list L is not empty. 
-- post - The first node is the current node. 
-- exceptions raised - LIST_UNDERFLOW if L is empty. 
begin 

if (EMPTY(L)) then 

raise LIST_UNDERFLOW; 

end if; 

L.CURRENT := L.HEAD; 
end FIND FIRST; 


procedure FIND _NEXT(L : in out LIST) is 
-- pre - The list L is not empty and the last node iS not the current node. 
-- post - c-next in L is the current node. 
-- exceptions raised - LIST _UNDERFLOW if L is empty. 
<= ~ LIST_OVERFLOW if the last node is the current node. 
begin 
if (EMPTY(L)) then 
raise LIST_UNDERFLOW; 
end if; 
if (LAST(L)) then 
raise LIST OVERFLOW, 
end if; 
L.CURRENT := L.CURRENT.NEXT; 
end FIND _NEXT; 


procedure FIND PREVIOUS(L : 1n out LIST) is 
-- pre - The list L is not empty and the first node is not the current node. 
-- post - c-prior in L is the current node. 
-- exceptions raised - LIST_UNDERFLOW if L is empty or c is the first node. 
TEMP_POINTER : NODE POINTER, 
begin 

1f CEMPTY(L) of FIRST(L)) then 
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raise LIST_UNDERFLOW; 

end if; 

TEMP_POINTER := L.HEAD; 

while (TEMP_POINTER.NEXT /= L.CURRENT) loop 
TEMP_POINTER := TEMP_POINTER.NEXT; 

end loop; 

L.CURRENT := TEMP_POINTER; 

end FIND PREVIOUS; 


procedure FIND_LAST(L : in out LIST) is 
-- pre - The list L is not empty. 
-- post - The last node in L is the current node. 
-- exceptions raised - LIST_UNDERFLOW if L is empty. 
begin 
1f (EMPTY(L)) then 
raise LIST_UNDERFLOW; 
end if; 
while (not LAST(L)) loop 
FIND _NEXT(L); 
end loop; 
end FIND_LAST; 


procedure RETRIEVE(L : in LIST; ITEM : out LIST_NODE_POINTER) is 
-- pre - The list L is not empty. 
-- post - ITEM contains the value of the element in the current node. 
-- exceptions raised - LIST_UNDERFLOW if L is empty. 
begin 

if (EMPTY(L)) then 

raise LIST_UNDERFLOW; 

end if; 

ITEM := L.CURRENT.ELEMENT; 
end RETRIEVE; 


procedure UPDATE(L : in out LIST; ITEM : in LIST_NODE_POINTER) is 
-- pre - The list L is not empty. 
-- post - The current node in L contains ITEM as its element. 
-- exceptions raised - LIST_UNDERFLOW if L is empty. 
begin 

if (EMPTY(L)) then 

raise LIST_UNDERFLOW; 

end if; 

L.CURRENT.ELEMENT := ITEM; 
end UPDATE; 


procedure INSERT(L : in out LIST; ITEM : in LIST_NODE_POINTER) is 

-- pre - The number of nodes in L has not reached its bound. 

-- post - A node containing ITEM is the last node in the list, and the last 
ie node in L-pre, if any, is its predecessor. The node containing 
= ITEM is the current node. 

-- exceptions raised - LIST _OVERFLOW if L has reached its bound. 

TEMP POINTER : NODE POINTER, 
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use SYMBOL_TABLE; 
begin 
if (FULL(L)) then 
raise LIST_OVERFLOW; 
end if; 
TEMP POINTER := new NODE'( ITEM, null); 
TEMP_POINTER.ELEMENT.SYMBOL.REFERENCE COUNT := 
natural '’SUCC(TEMP_POINTER.ELEMENT .SYMBOL .REFERENCE_COUNT ); 
if (L.HEAD = null) then 
L.HEAD := TEMP_POINTER; 
L.TAIL := TEMP_POINTER; 
else 
L.TAIL.NEXT := TEMP_POINTER; 
L.TAIL TEMP_POINTER; 
end if; 
L.CURRENT := TEMP_POINTER; 
L.SIZE 22 Size 1s 
end INSERT; 


procedure DELETE(L : in out LIST) is 
-- pre - The list L is not empty. 
-- post - c-pre in not in the list L. If c-pre was the first node, 
a then c-next, if it exists, is the successor of c-prior. If the 
-- list L is not empty, then the last node is the current node. 
-- exceptions raised - LIST_UNDERFLOW if L is empty. 
TEMP_POINTER : NODE_POINTER; 
use SYMBOL_TABLE; 
begin 
if (EMPTY(L)) then 
raise LIST_UNDERFLOW; 
end if; 
if (L.CURRENT /= L.HEAD) then 
TEMP POINTER := L.HEAD; 
while (TEMP _POINTER.NEXT /= L.CURRENT) loop 
TEMP_POINTER := TEMP _POINTER.NEXT; 
end loop; 
TEMP_POINTER.NEXT := L.CURRENT.NEXT; 
if (L.CURRENT = L.TAIL) then 
L.TAIL := TEMP_POINTER; 
end if; 
else 
if (L.HEAD = L.TAIL) then 
L.TAIL := null; 
end if; 
L.HEAD := L.HEAD.NEXT; 
end if; 
if (L.CURRENT.ELEMENT.SYMBOL .REFERENCE COUNT > 1) then 
L.CURRENT.ELEMENT .SYMBOL .REFERENCE COUNT := 
positive’ PREO(L.CURRENT .ELEMENT .SYMBOL .REFERENCE COUNT); 
else 
FREE SYM REC(L.CURRENT. ELEMENT .SYMBOL ) ; 
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end if; 

FREE _NODE(L.CURRENT); 

L.CURRENT := L.TAIL; 

Bolte = L.SIZE = 1; 
end DELETE; 


function SIZE OF(L : in LIST) return natural is 
-- post - SIZE_OF is the number of nodes in list L. 
begin 
return (L.SIZE); 
end SIZE_OF; 


function EMPTY(L : in LIST) return boolean is 
-- post - If the list L has no nodes then EMPTY is true, else EMPTY is 
aS false. 
begin 
return (L.HEAD = null); 
end EMPTY; 


function FULL(L : in LIST) return boolean is 
-- post - If the number of nodes in the list L has reached the maximum 
2S allowed, then FULL is true, else FULL is false. 
TEMP_POINTER : NODE_POINTER; 
begin 
TEMP_POINTER := new NODE; 
FREE_NODE( TEMP_POINTER); 
return (FALSE); 
exception 
when STORAGE _ERROR => 
return (TRUE); 
when others => 
raise; 
end FULL; 


function FIRST(L : in LIST) return boolean is 
-- pre - The list L is not empty. 
-- post - If the first node is the current node in L then FIRST is true, else 
== FIRST is false. 
-- exceptions raised - LIST_UNDERFLOW if L is empty. 
begin 

if (EMPTY(L)) then 

raise LIST_UNDERFLOW; 

end if; 

return (L.CURRENT = L.HEAD); 
end FIRST; 


function LAST(L : in LIST) return boolean is 

-- pre - The list L is not empty. 

-- post - If the last node 1s the current node in L then LAST is true, else 
== LAST is false. 

-- exceptions raised - LIST _UNDERFLOW 1f L is empty. 
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begin 
if (EMPTY(L)) then 
raise LIST_UNDERFLOW; 
end if; 
return (L.CURRENT = L.TAIL); 
end LAST; 


procedure CREATE(L : in out LIST; SUCCESS : out boolean) is 
-- post - If a list L can be created then L exists and is empty, and SUCCESS 
-- is TRUE else SUCCESS is FALSE. 
begin 
L := new LIST_INSTANCE'(null, null, null, 0); 
SUCCESS := TRUE; 
exception 
when STORAGE ERROR => 
SUCCESS ;:= FALSE; 
when others => 
raise; 
end CREATE; 


procedure DISPOSE(L : in out LIST) is 
-- post - L-pre does not exist. 
begin 
if (not EMPTY(L)) then 
FIND_LAST(L); 
while (not EMPTY(L)) loop 
DELETE(L); 
end loop; 
end if; 
FREE_LIST(L): 
end DISPOSE; 


end ABSTRACT _SYNTAX_LIST; 


function CREATE_DUMMY PLACE(LABEL : in string) 
return LIST_NODE_POINTER is 
-- post - a place is created with a unique code block number and given 
a5 a tag denoted by LABEL. CREATE_DUMMY_ PLACE returns a pointer 
-- to a syntax list node that now contains this place. 
LOCATION : positive; 
TEMP POINTER : LIST_NODE_ POINTER; 
begin 
CODE BLOCKER.ENTER_CODE_BLOCK(DUMMY SOURCE, LABEL); 
LOCATION := CODE_BLOCKER.CURRENT CODE_BLOCK_NUMBER; 
CODE _BLOCKER.EXIT_CODE BLOCK(DUMMY SOURCE); 
TEMP_POINTER := new LIST_NODE; 
TEMP _POINTER.PETRI_ TAG := PLACE; 
TEMP_POINTER.SYMBOL := new SYMBOL _TABLE.SYM_TAB_RECORD; 
TEMP_POINTER.SYMBOL.NAME := (others => ' '); 
TEMP POINTER.SYMBOL .NAME LENGTH := Q; 
TEMP POINTER.SYMBOL .LOCATION := LOCATION; 
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TEMP_POINTER.SYMBOL.REFERENCE COUNT := 0; 
return (TEMP POINTER); 
exception 
when STORAGE ERROR => 
raise NET GENERATOR OVERFLOW; 
when others => 
raise; 
end CREATE_DUMMY PLACE; 


function NUMBER TO _LIST_NODE(CURRENT LOCATION : 


-- post - NUMBER_TO_LIST_NODE returns a pointer 


in positive) 


return LIST_NODE_POINTER is 


ie to a syntax list node that now contains this place. 


TEMP_POINTER : LIST_NODE_POINTER; 
begin 
TEMP_POINTER := new LIST_NODE; 
TEMP_POINTER.PETRI_TAG := PLACE; 


TEMP POINTER.SYMBOL := new SYMBOL _TABLE.SYM_TAB_RECORD; 


TEMP_POINTER.SYMBOL.NAME := (others => ' '); 
TEMP_POINTER.SYMBOL.NAME_LENGTH := 0; 


TEMP_POINTER.SYMBOL.LOCATION := CURRENT LOCATION; 


TEMP_POINTER.SYMBOL.REFERENCE_COUNT := 0; 
return (TEMP_POINTER) ; 
exception 
when STORAGE_ERROR => 
raise NET_GENERATOR_OVERFLOW; 
when others => 
raise; 
end NUMBER _TO_LIST_NODE; 


function POINTER _TO_LIST_NODE(LOCATION : in SYMBOL_TABLE.SYM_TAB_ ACCESS) 


-- post - POINTER TO_LIST_NODE returns a pointer 


return LIST_NODE_POINTER is 


== to a syntax list node that now contains this place. 


TEMP_POINTER : LIST_NODE_POINTER; 
begin 
TEMP_POINTER := new LIST_NODE; 
TEMP_POINTER.PETRI_TAG := PLACE; 
TEMP_POINTER.SYMBOL := LOCATION; 
return (TEMP POINTER); 
exception 
when STORAGE_ERROR => 
raise NET GENERATOR OVERFLOW; 
when others => 
raise; 
end POINTER TO LIST_NODE; 


procedure NEW_SYNTAX_ LIST is 


-- pre - The forest size has not reached it's bound. 
-- post - An empty syntax list is inserted into the forest and becomes the 


= current element in the forest. 


165 


TEMP_SYNTAX ; ABSTRACT_SYNTAX_LIST.LIST; 
SUCCESS : boolean; 
begin 
ABSTRACT_SYNTAX_LIST.CREATE( TEMP_SYNTAX, SUCCESS); 
if (not SUCCESS) then 
raise NET GENERATOR OVERFLOW; 
end if; 
if (not FOREST _LIST.FULL(FOREST)) then 
FOREST_LIST.INSERT( FOREST, TEMP_SYNTAX) ; 
else 
raise NET_GENERATOR_OVERFLOW; 
end if; 
end NEW_SYNTAX_LIST; 


procedure INITIALIZE NET_GENERATOR is 


SUCCESS : boolean; 

begin 
DUMMY SOURCE .FILE NAME = (others => ' '); 
DUMMY SOURCE .FILE_NAME_SIZE := 0; 


DUMMY _SOURCE .LINE_NUMBER := 0; 
ABSTRACT_SYNTAX_LIST.CREATE(START_SYNTAX, SUCCESS); 
if (not SUCCESS) then 

raise NET_GENERATOR_ OVERFLOW; 
end if; 
ABSTRACT_SYNTAX_LIST.INSERT(START_SYNTAX, 

CREATE _DUMMY_PLACE("START”)); 

TRANSITION_POINTER := new LIST_NODE; 
TRANSITION _POINTER.PETRI_ TAG := TRANSITION; 
TRANSITION POINTER.SYMBOL := new SYMBOL_TABLE.SYM_TAB_RECORD; 
TRANSITION POINTER.SYMBOL .NAME := (others => ' '); 
TRANSITION_POINTER.SYMBOL .NAME_LENGTH := 0; 
TRANSITION_POINTER.SYMBOL.LOCATION := 0; 
TRANSITION_POINTER.SYMBOL .REFERENCE COUNT := 0; 
ABSTRACT_SYNTAX_LIST.INSERT(START_SYNTAX, TRANSITION POINTER); 
ABSTRACT_SYNTAX_LIST.CREATE(STOP_PLACES, SUCCESS) ; 
if (not SUCCESS) then 

raise NET_GENERATOR OVERFLOW; 
end if; 
FOREST_LIST.CREATE( FOREST, SUCCESS); 
if (not SUCCESS) then 

raise NET _GENERATOR_OVERFLOW; 
end if; 
NEST STACK.CREATE(NS, SUCCESS); 
if (not SUCCESS) then 

raise NET GENERATOR OVERFLOW; 
end if; 
NEW SYNTAX LIST; 

exception 

when STORAGE ERROR => 

raise NET GENERATOR OVERFLOW; 
when others => 
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raise; 
end INITIALIZE NET GENERATOR; 


procedure RESET_NET_GENERATOR is 
-- post - The net generator is returned to it's initial state. 
TEMP_ASL : ABSTRACT _SYNTAX_LIST.LIST; 
SUCCESS : boolean; 
begin 
ABSTRACT_SYNTAX_LIST.DISPOSE(START_SYNTAX); 
if (not FOREST _LIST.EMPTY(FOREST)) then 
FOREST _LIST.FIND_LAST( FOREST); 
while (not FOREST_LIST.EMPTY(FOREST)) loop 
FOREST _LIST.RETRIEVE( FOREST, TEMP_ASL); 
ABSTRACT_SYNTAX_LIST.DISPOSE(TEMP_ASL); 
FOREST _LIST.DELETE( FOREST); 
end loop; 
end if; 
ABSTRACT _SYNTAX_LIST.DISPOSE(STOP_PLACES) ; 
ABSTRACT_SYNTAX_LIST.CREATE(START_SYNTAX, SUCCESS); 
if (not SUCCESS) then 
raise NET GENERATOR OVERFLOW; 
end if; 
ABSTRACT_SYNTAX_LIST.CREATE(STOP_PLACES, SUCCESS); 
if (not SUCCESS) then 
raise NET_GENERATOR_OVERFLOW; 
end if; 
ABSTRACT_SYNTAX_LIST.INSERT(START_SYNTAX, 
CREATE _DUMMY_ PLACE("START")); 
TRANSITION POINTER := new LIST_NODE; 
TRANSITION POINTER.PETRI_TAG := TRANSITION; 
TRANSITION POINTER.SYMBOL := new SYMBOL_TABLE.SYM_TAB_RECORD; 
TRANSITION POINTER.SYMBOL.NAME := (others => ' '); 
TRANSITION _POINTER.SYMBOL.NAME_LENGTH := Q; 
TRANSITION POINTER.SYMBOL .LOCATION := 0; 
TRANSITION_POINTER.SYMBOL.REFERENCE COUNT := Q; 
ABSTRACT_SYNTAX_LIST.INSERT(START_SYNTAX, TRANSITION POINTER); 
NEW _SYNTAX_LIST; 
end RESET _NET_GENERATOR; 


function IS COMPLETE return boolean is 
-- post - If the current syntax list in the forest is empty, then 
cia IS COMPLETE returns true, else IS COMPLETE returns false. 
TEMP_SYNTAX : ABSTRACT_SYNTAX_LIST.LIST; 
begin 

FOREST _LIST.RETRIEVE( FOREST, TEMP SYNTAX); 

return (ABSTRACT SYNTAX _LIST.EMPTY( TEMP_SYNTAX)); 
end IS_COMPLETE; 


procedure INSERT _FOREST(TRANS OR PLACE : in LIST NODE POINTER) is 


-- post - The specified transition or place is inserted into the forest 
26 in the current syntax list. 
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procedure gTART( RUN_UNT_NAME : in sywaot TABLE, SHH_TAB_ACESS us 
== post” Oefines 4 either 4 subprogram place or task place that has 


ENO MARKER YMBOL TABLE sym_TAB ACCESS: 
beg! 
RUN_UNIT_NOO = POINTER_10_ -g1_NOOE( RUN_UNET NAME 


ey NT NAME .NAWE_LENGTE) 


ren. To_11St_HOOE(EH0_MARIEE 


procedure secTStON_START(START PLATE : in positive: 
eNO _PLACE : in oe. TABLE -SYM_TAB_ACEESE is 
e005 a Defines 4 place that 7S the root place of a multi-way decision 


WEST STACK -PUSH(NS: peC1SON ROOT): 

WEST STACK -PUSH(NS: ofc ISION_TAIL) 
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procedure peciSTONOR(END_PATH PLAS : in positive) is 
-- post ~ Ends the current path of a multi-way decision and starts the 
-- next path. The decisi10n start place is reactivated as the 
ae current block number - 
START _NOOE ‘ _1gT_NOOE_POINTER: 
pegif 
START_NODE := saath 10 L15T_NODE(END PATH PRES 
af (not 1s COMPLETE) then 
Arent FOREST(START MOPED: 
new SYNTAX_LIST: 
end if; 
HN cat FORESTS 
SE REST TANSETION FOT8IES 
wt ar _fonesT(oeCESION_TATL): 
yew SYNTAK_LISTS 
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CODE _BLOCKER.REACTIVATE CODE _BLOCK(DECISION ROOT.SYMBOL .LOCATION); 
end DECISION OR; 


procedure EXPLICIT DECISION _OR is 
-- post - Ends the current path of a multi-way decision and starts the 
Je next path. The decision start place is reactivated as the 
ie current block number. 
begin 
if (not IS COMPLETE) then 
INSERT_FOREST(DECISION_TAIL); 
NEW_SYNTAX_LIST; 
CODE_BLOCKER.REACTIVATE CODE _BLOCK(DECISION ROOT .SYMBOL .LOCATION) ; 
end if; 
end EXPLICIT DECISION OR; 


procedure END DECISION(END_PATH_PLACE : in positive) is 
-- post - Ends the current path of a multi-way decision and terminates 
== the multi-way decision. 
START_NODE : LIST _NODE_POINTER; 
begin 
START_NODE := NUMBER_TO_LIST_NODE(END_PATH PLACE); 
if (not IS_COMPLETE) then 
INSERT_FOREST(START_NODE) ; 
NEW_SYNTAX_LIST; 
end if; 
INSERT_FOREST(START_NODE) ; 
INSERT_FOREST( TRANSITION_POINTER); 
INSERT_FOREST(DECISION_TAIL); 
NEW_SYNTAX_LIST; 
INSERT_FOREST(DECISION_TAIL); 
INSERT_FOREST( TRANSITION_POINTER) ; 
NEST _STACK.POP(NS, DECISION TAIL); 
NEST_STACK.POP(NS, DECISION ROOT); 
end END DECISION; 


procedure EXPLICIT_END_ DECISION is 
-- post - Ends the current path of a multi-way decision and terminates 
a the multi-way decision. 
begin 
if (not IS_COMPLETE) then 
INSERT_FOREST(DECISION TAIL); 
NEW SYNTAX LIST; 
end if; 
INSERT _FOREST(DECISION TAIL); 
INSERT _FOREST( TRANSITION POINTER); 
NEST_STACK.POP(NS, DECISION TAIL); 
NEST_STACK.POP(NS, DECISION ROOT); 
end EXPLICIT_END DECISION; 


procedure CALL(CURRENT LOCATION : in positive; 
PROCEDURE LOCATION : in SYMBOL_TABLE.SYM TAB ACCESS) 1s 
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-- pre - The procedure location must be the current entry in the 
ai symbol table. 
-- post - The abstract grammar for a procedure call is generated. 
START_NODE : LIST_NODE_POINTER; 
WAIT_NODE : LIST_NODE_ POINTER; 
TEMP_POINTER : SYMBOL_TABLE.SYM_TAB_ACCESS; 
begin 
START_NODE NUMBER_TO_LIST_NODE(CURRENT LOCATION); 
WAIT _NODE := CREATE DUMMY PLACE("WAIT RETURN"); 
SYMBOL_TABLE.SAVE_CURRENT_ENTRY; 
TEMP_POINTER := SYMBOL_TABLE.SELECT COMPONENT( "END"); 
SYMBOL_TABLE .RESTORE_CURRENT_ENTRY; 
if (not IS_COMPLETE) then 
INSERT_FOREST(START_NODE ) ; 
NEW_SYNTAX_LIST; 
end if; 
INSERT_FOREST(START NODE); 
INSERT_FOREST( TRANSITION POINTER); 
INSERT_FOREST(POINTER_TO LIST_NODE(PROCEDURE_LOCATION) ); 
INSERT_FOREST(WAIT_NODE); 
NEW SYNTAX LIST; 
INSERT_FOREST(WAIT_NODE); 
INSERT_FOREST(POINTER_TO_LIST _NODE( TEMP POINTER) ); 
INSERT_FOREST( TRANSITION POINTER); 
end CALL; 
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procedure ENTRY_CALL(CURRENT LOCATION : in positive; 
ENTRY_LOCATION : in SYMBOL_TABLE.SYM_TAB_ ACCESS) is 
-- pre - The entry location must be the current entry in the 
aa symbol table. 
-- post - The abstract grammar for a task entry is generated. 
START_NODE : LIST _NODE_POINTER; 
WAIT_NODE ; LIST_NODE_POINTER; 
TEMP_POINTER : SYMBOL_TABLE.SYM_TAB_ACCESS; 


begin 
START_NODE := NUMBER _TO_LIST_NODE(CURRENT_ LOCATION) ; 
WAIT_NODE = CREATE DUMMY PLACE("WAIT RENDEZVOUS") ; 


SYMBOL_TABLE.SAVE_CURRENT_ ENTRY; 
TEMP_POINTER := SYMBOL_TABLE.SELECT COMPONENT( "END" ); 
SYMBOL_TABLE.RESTORE_CURRENT_ ENTRY; 
if (not IS COMPLETE) then 
INSERT_FOREST( START NODE); 
NEW_SYNTAX_ LIST; 
end if; 
INSERT _FOREST( START_NODE ); 
INSERT _FOREST( TRANSITION POINTER); 
INSERT _FOREST( POINTER _TO LIST NODE( ENTRY _LOCATION)); 
INSERT FOREST(WAIT NODE); 
NEW SYNTAX LIST; 
INSERT FOREST(WAIT NODE); 
INSERT FOREST(POINTER TO LIST NODE( TEMP _POINTER)); 
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INSERT_FOREST( TRANSITION POINTER); 
end ENTRY_CALL; 


procedure TASK_ACCEPT(CURRENT LOCATION : in positive; 
ENTRY LOCATION : IN positive) is 
-- post - The abstract grammar for a task accept is generated. 
START_NODE : LIST_NODE_POINTER; 
begin 
START_NODE := NUMBER_TO_LIST_NODE(CURRENT_ LOCATION) ; 
if (not IS_COMPLETE) then 
INSERT_FOREST(START_NODE); 
NEW_SYNTAX_LIST; 
end if; 
INSERT_FOREST(START_NODE) ; 
INSERT_FOREST(NUMBER_TO_LIST_ NODE(ENTRY_LOCATION)); 
INSERT_FOREST( TRANSITION POINTER); 
end TASK_ACCEPT; 


procedure END_ACCEPT(CURRENT LOCATION : in positive; 
ENTRY_END : in positive) is 
-- post - The abstract grammar for the end of an accept statement is 
-- generated. 
CURRENT NODE : LIST_NODE_ POINTER; 
LOOP_POINTER : SYMBOL_TABLE.SYM_TAB_ACCESS; 
begin 
CURRENT_NODE := NUMBER TO_LIST_NODE(CURRENT_ LOCATION); 
if (not IS_COMPLETE) then 
INSERT_FOREST(CURRENT_ NODE) ; 
NEW _SYNTAX_LIST; 
end if; 
INSERT_FOREST(CURRENT NODE); 
INSERT_FOREST( TRANSITION POINTER); 
INSERT_FOREST(NUMBER_TO_LIST_NODE(ENTRY_END)); 
end END ACCEPT; 


procedure EXPLICIT_END_ACCEPT(ENTRY_END : in positive) is 
-- post - The abstract grammar for the end of an accept statement is 
generated. 
begin 

if (mot IS COMPLETE) then 

INSERT FOREST(NUMBER_TO_LIST_NODE(ENTRY_END)); 

end if; 

end EXPLICIT_END ACCEPT; 


procedure GO _TO(CURRENT LOCATION : in positive; 
GO_TO_LOCATION : in SYMBOL_TABLE.SYM TAB_ACCESS) is 
-- post - The abstract grammar for a goto statement is generated. 
START NODE : LIST_NODE POINTER; 
begin 
START NODE := NUMBER TO LIST NODE(CURRENT LOCATION); 
if (mot IS COMPLETE) then 
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INSERT _FOREST(START_NODE ); 
NEW_SYNTAX_LIST; 
end if; 
INSERT_FOREST(START_NODE ); 
INSERT_FOREST( TRANSITION POINTER) ; 
INSERT_FOREST( POINTER _TO_ LIST _NODE(GO_TO_LOCATION)); 
NEW _SYNTAX_LIST; 
end GO_TO; 


procedure END_LOOP(END_LOCATION : in positive; 
LOOP_START : in SYMBOL_TABLE.SYM_TAB_ACCESS) is 
-- post - The abstract grammar for a loop is generated. 
END_NODE : LIST_NODE_ POINTER; 
LOOP_POINTER : SYMBOL_TABLE.SYM_TAB_ACCESS; 
begin 
END_NODE := NUMBER TO _LIST_NODE(END_LOCATION); 
if (mot IS COMPLETE) then 
INSERT_FOREST(END_NODE) ; 
NEW SYNTAX_LIST; 
end if; 
INSERT_FOREST(END_NODE) ; 
INSERT_FOREST( TRANSITION POINTER); 
INSERT_FOREST(POINTER_TO_LIST_NODE(LOOP_START)); 
end END_LOOP; 


procedure CONNECT BLOCKS(CURRENT LOCATION : in positive; 
NEXT LOCATION : in positive) is 
-- post - used to explicitly declare a transition between two known 
== code blocks. The abstract grammar for a transition between 
os two petri net places is generated. 
START_NODE : LIST_NODE POINTER; 
begin 
START_NODE := NUMBER_TO_LIST_NODE( CURRENT LOCATION) ; 
if (not IS COMPLETE) then 
INSERT_FOREST(START_NODE ) ; 
NEW _SYNTAX_LIST; 
end if; 
INSERT_FOREST(START_NODE ); 
INSERT_FOREST( TRANSITION POINTER); 
INSERT_FOREST(NUMBER_TO_LIST_NODE(NEXT_LOCATION)); 
NEW _SYNTAX_LIST; 
end CONNECT BLOCKS; 


procedure EXPLICIT END(NEXT LOCATION : in positive) is 
-- post - The current forest is terminated and a new forest is begun. 
begin 
if (mot IS COMPLETE) then 
INSERT _FOREST(NUMBER_TO_LIST NODE(NEXT LOCATION) ); 
NEW SYNTAX LIST; 
end if; 
end EXPLICIT END; 
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procedure TRANSLATE _TO PEANUT jis 
-- post - used to translate the abstract petri net grammar to a 
sie text file used as an input file to P-NUT petri net analyzer. 
-- Produces two files: 1) a.out - P-NUT input file 
a= 2) place.dat - text file that describes al] 
oe the places that exist in the 
= petri net and/or the 
-- places relation to the 
== original source code. 
oe The net generator and code blocker are reset to their 
=e initial states. 
TRANSITION_NUMBER : positive := 1; 
NET_FILE : TEXT_IO.file_type; 
SYNTAX_LIST : ABSTRACT_SYNTAX_LIST.LIST; 
INITIAL_MARK : LIST_NODE_POINTER; 
PLACE_FILE : TEXT_IO.file_ type; 
START_SOURCE_INFO : TOKEN SCANNER.SOURCE_RECORD; 
STOP _SOURCE_INFO : TOKEN SCANNER.SOURCE_ RECORD; 
function POS TO_LIT(NUMBER : string) return string is 
begin 
return (NUMBER(2..NUMBER'LAST)); 
end POS TO LIT; 
procedure XLATE(SYNTAX_LIST : in out ABSTRACT_SYNTAX_LIST.LIST) is 
package PLACE_STACK is new GENERIC_STACK(LIST_NODE_POINTER); 
TEMP_POINTER : LIST_NODE_POINTER; 
PS : PLACE_STACK.STACK; 
SUCCESS : boolean; 
begin 
PLACE STACK.CREATE(PS, SUCCESS); 
if (not SUCCESS) then 
raise NET GENERATOR OVERFLOW; 
end if; 
if (mot ABSTRACT_SYNTAX_LIST.EMPTY(SYNTAX_LIST)) then 
ABSTRACT_SYNTAX_LIST.FIND_FIRST(SYNTAX_LIST); 
ABSTRACT_SYNTAX_LIST.RETRIEVE(SYNTAX_LIST, TEMP_POINTER); 
while (TEMP_POINTER.PETRI_TAG /= TRANSITION) loop 
PLACE _STACK.PUSH(PS, TEMP POINTER); 
ABSTRACT_SYNTAX_LIST.FIND_NEXT(SYNTAX_LIST); 
ABSTRACT_SYNTAX_LIST.RETRIEVE( SYNTAX_LIST, TEMP POINTER); 
end loop; 
ABSTRACT_SYNTAX_LIST.FIND_NEXT(SYNTAX_LIST); --skip transition pointer 
NEXIS IG put(NeT_FILe, “:t"); 
TEXT_IO.put(NET_ FILE, POS TO LIT(positive' IMAGE( TRANSITION NUMBER) )); 
TRANSITION NUMBER := TRANSITION NUMBER + 1; 
TEXT _TO2puc(NET FILE, *: “); 
PLACE_STACK.POP(PS, TEMP_POINTER); 
TEX TerO.put( NET FILE, “p”); 
TEXT_I0.put(NET_FILE, POS TO _LIT(positive'IMAGE( TEMP POINTER. 
SYMBOL .LOCATION))); 
while (not PLACE _STACK.EMPTY(PS)) loop 
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PLACE_STACK.POP(PS, TEMP_POINTER); 
TEXT_IG.put(NET_PILES | 0"): 
TEXT_IO.put(NET_FILE, POS _TO_LIT(positive'’ IMAGE(TEMP_POINTER. 
SYMBOL .LOCATION))); 
end loop; 
PLACE_STACK.DISPOSE( PS); 
TEXT_IO.put(NEl_Fibce, ==): 
ABSTRACT_SYNTAX_LIST.RETRIEVE(SYNTAX_LIST, TEMP_POINTER); 
TEXT_I0.put(NETLFILE. “p"); 
TEXT_IO.put(NET_FILE, POS_TO_LIT(positive'IMAGE(TEMP_POINTER. 
SYMBOL .LOCATION))); 
while (not ABSTRACT_SYNTAX_LIST.LAST(SYNTAX_LIST)) loop 
ABSTRACT_SYNTAX_LIST.FIND_NEXT(SYNTAX_LIST); 
ABSTRACT_SYNTAX_LIST.RETRIEVE(SYNTAX_LIST, TEMP_POINTER); 
TEXT_10.put(NET_FILE, *, p”); 
TEXT IO.put(NET_FILE, POS_TO_LIT(positive’ IMAGE( TEMP POINTER. 
SYMBOL .LOCATION))); 
end loop; 
TEXT_I0.new_line(NET FILE); 
end if; 
end XLATE; 
begin 
begin 
TEXT_I0.create(NET FILE, TEXT_I0.out_file, "a.out", ""); 
exception 
when IQ_EXCEPTIONS.USE ERROR => 
TEXT_I0.open(NET_ FILE, TEXT _IO0.out_file, “a.out", ""); 
when others => raise; 
end; 
if (not FOREST _LIST.EMPTY(FOREST)) then 
XLATE( START_SYNTAX); 
FOREST _LIST.FINO_FIRST( FOREST); 
FOREST_LIST.RETRIEVE( FOREST, SYNTAX_LIST); 
XLATE(SYNTAX_LIST); 
while (not FOREST LIST.LAST(FOREST)) loop 
FOREST_LIST.FIND_NEXT( FOREST); 
FOREST _LIST.RETRIEVE( FOREST, SYNTAX_LIST); 
XLATE(SYNTAX_LIST); 
end loop; 
ABSTRACT_SYNTAX_LIST.INSERT(STOP_PLACES, TRANSITION_POINTER); 
ABSTRACT_SYNTAX_LIST.INSERT(STOP_PLACES, CREATE OUMMY PLACE("STOP")); 
XLATE(STOP_PLACES); 
TEXT_10, put(NeT GEILE, <p"); 
ABSTRACT _SYNTAX_LIST.FIND_FIRST(START_ SYNTAX); 
ABSTRACT SYNTAX _LIST.RETRIEVE(START_ SYNTAX, INITIAL_MARK); 
TEXT_IO.put(NET FILE, POS TO_LIT(positive' IMAGE(INITIAL_MARK. 
SYMBOL .LOCATION))); 
TEXT STO pub(NETSPILES >" %: 
TEXT 10. close( NET FILE}; 
end if; 
begin 
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TEXT_I0.create(PLACE_FILE, TEXT_IO0.out_file, “place.dat”, ""); 
exception 
when IO_EXCEPTIONS.USE_ ERROR => 
TEXT_IO0.open(PLACE_FILE, TEXT_I0.out_file, "“place.dat", °"); 
when others => raise; 
end; 
if (not CODE_BLOCKER.IS CODE_BLOCK LIST CLEAR) then 
CODE_BLOCKER.FIND_FIRST_CODE_B8LOCK; 
TEXT _IO0.put(PLACE_FILE, "LOCATION"); 
TEXT_I0.set_col(PLACE_FILE, 20); 
TEXT_I0.put(PLACE_FILE, "CODE_BLOCK_LABEL"); 
TEXT_I0.set_col(PLACE_FILE, 50); 
TEXT IO.put(PLACE FILE, “STARTING LINE"); 
TEXT_T0O.set_col(PLACE_ FILE, 65); 
TEXT_IO.put(PLACE_FILE, “ENDING LINE"); 
TEXT _IO0.new_line(PLACE FILE, 2); 
loop 
TEXT _ITO.put(PLACE FILE, "p"); 
TEXT_IO.put(PLACE_FILE, POS _TO_LIT(positive' IMAGE(CODE_BLOCKER. 
READ_CODE_BLOCK_NUMBER))); 
TEXT_IO.set_col(PLACE_FILE, 20); 
TEXT_IO0.put(PLACE_FILE, CODE _BLOCKER.READ_CODE_8LOCK_ LABEL); 
START_SOURCE_INFO := CODE_BLOCKER.READ_CODE_BLOCK_START; 
STOP_SOURCE_INFO := CODE_BLOCKER.READ_CODE_BLOCK_STOP; 
TEXT_I0.set_col(PLACE_FILE, 55); 
TEXT_IO.put(PLACE FILE, natural’ IMAGE(START_SOURCE_INFO.LINE_NUMBER) ); 
TEXT_IO.set_col(PLACE_ FILE, 70); 
TEXT ITO.put_line(PLACE FILE, natural’ IMAGE(STOP_SOURCE_INFO. 
LINE _NUMBER)); 
exit when CODE_BLOCKER.IS_LAST CODE BLOCK; 
CODE _BLOCKER.FIND NEXT CODE BLOCK; 
end loop; 
TEXT I10.close(PLACE_FILE); 
CODE_BLOCKER.CLEAR_CODE_BLOCKER;; 
RESET_NET_GENERATOR; 
end if; 
end TRANSLATE_TO_PEANUT; 


begin 


INITIALIZE_NET_GENERATOR; 
end NET GENERATOR; 
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APPENDIX E 
“ADAFLOW” PROGRAM LISTING - SYMBOL TABLE 


——SFSFSSSSSSSTSSSSSSSSSSSSSSSSSSSSSTSSSSSSSESSSSSSSSSSSSSSSSSVBIBEBSEB__ 


-- TITLE: ADAFLOW -- 
-- MODULE NAME: — PACKAGE SYMBOL_TABLE -- 
-- FILE NAME: SYM_TAB.ADS -- 


-- DATE CREATED: 01 MAR 88 aa 
-- LAST MODIFIED: 28 APR 88 ae 


== AUTHOR(S): LT ALBERT J. GRECCO, USN == 


-- DESCRIPTION: This package contains the procedures which -- 
as define the interface to the symbol table. == 


——- SSS SSESIFSTSSSF SSS SSISSSSTFSSRSF SSI SSSSE SSK SSSESSSTSSCTS SSS SSSSSSBSEsss_—_ 


with TOKEN SCANNER; 
package SYMBOL_TABLE is 
type SYMBOL_TAG is (OBJECT _DECLARATION_TAG, TYPE DECLARATION_TAG, 


FUNCTION DECLARATION TAG, PROCEDURE _DECLARATION_TAG, 
PACKAGE_DECLARATION_TAG, TASK_DECLARATION_TAG, 


ENTRY_TAG, 

PACKAGE_BODY_TAG, TASK_BODY_TAG, 
ACCEPT_TAG, LABEL_NAME, 
SELECT_TAG, LOOP_TAG); 


type SYM _TAB_RECDRD is 


record 
NAME > String(1..TOKEN SCANNER.LINESIZE) := (others => ' '); 
NAME LENGTH ; natural’ == 0; 
TAG_TYPE : SYMBOL_TAG; 
LOCATION : natural := 0; -- 0 indicates undeclared. 
REFERENCE COUNT : natural := 0; -- used to count the number of 
end record; -- pointers to this entry. ODO NOT 


-- COLLECT GARBAGE UNLESS THIS IS 1. 


type SYM TAB_ACCESS is access SYM_TAB_RECORD; 
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SYMBOL _TABLE_OVERFLOW : exception; 
DECLARATION_ERROR > exception; 
REFERENCE_ERROR > exception; 


procedure CLEAR _SYM_TAB; 
-- post - SYM_TAB is returned to it's initialized state. 


function FULL_SYM_TAB return boolean; 
-- post - If the size of SYM TAB has not reached its bound then FULL is 
-- FALSE else FULL is TRUE. 


procedure EXIT SCOPE; 

-- post - SYM_TAB backs up one static nesting level. The current entry is 
ae defined as the entry that caused the corresponding scope entry to 
=< occur. 


procedure INSERT_SYM_TAB(KEY > in string; 
ATTRIBUTE : in SYMBOL_TAG; 
LOCATION : in natural); 
-- pre - SYM_TAB has not achieved its maximum allowable size. 
-- post - If the ATTRUBUTE is OBJECT DECLARATION TAG, TYPE_CECLARATION_TAG, 
== or LABEL_NAME, a search is conducted at the local SNL for a 
oi matching KEY. If no match is found, KEY is inserted with the given 
=- attribute and location and is the the current entry, else no 
aS action is taken and the current entry is the pre-existing entry 
oS named by key. 
= If the ATTRIBUTE is FUNCTION DECLARATION _TAG, 
= PROCEDURE _DECLARATION_TAG, PACKAGE DECLARATION_TAG, 
== TASK_DECLARATION_TAG, or ENTRY_TAG, a search is conducted at the 
-= local SNL for a matching KEY. If no match is found, KEY is inserted 
os with the given attribute and location and scope entry occurs, else 
ae a check is made to see if the pre-existing entry is a 
ao PROCEDURE DECLARATION _TAG or a FUNCTION DECLARATION TAG. If so, 
== location is updated and scope entry occurs. 
= If the ATTRIBUTE is PACKAGE _BODY_TAG, TASK _BODY_TAG, or 
2s ACCEPT_TAG, the corresponding environment of definition is 
ee located, the location updated, and then scope entry occurs. 
a If the ATTRIBUTE is LOOP_TAG or SELECT_TAG, the symbol is entered 
== with the given ATTRIBUTE and LOCATION and scope entry occurs. 
-- exceptions raised - SYMBOL_TABLE_OVERFLOW if the symbol table’s size 
== has reached it's bound. 
= DECLARATION_ERROR if the required environment of 
=> definition can not be found for a body declaration 
=< or if a declaration tag already exists at the current 
= SNL. 


function FIND _KEY(KEY : in string) return SYM_TAB_ACCESS; 

-- post - If the symbol table contains an entry whose key value is KEY, 
oe then that entry is the current entry and FIND KEY returns a 
ae pointer to that symbol table record, else FIND _KEY returns 

i a null pointer and the current entry is undefined. NOTE - 


ia, 


aa the symbol table IS case sensitive in it's comparison of keys and 
aE the search is global in scope according to ADA visibility rules. 


function FIND _LOCAL_KEY(KEY : in string) return SYM_TAB_ACCESS; 

-- post - If the symbol table contains an entry whose key value is KEY, 

== then that entry is the current entry and FIND_KEY returns a 

oe pointer to that symbol table record, else FIND_KEY returns 

<= a null pointer and the current entry is undefined. NOTE - 

a the symbol table IS case sensitive in it's comparison of keys and 
aS the search is local in scope according to ADA visibility rules. 


function FIND SUBPROGRAM_END return SYM_TAB_ACCESS; 

-- post - A search is conducted to find the parent enclosing subprogram 

oc of the parse. A pointer to the label "END" for this parent 

aa enclosing subprogram is returned. This function is used to 

i provide the operand for a “return” statement. The current entry 
= is the corresponding end label for the enclosing subprogram of the 
== parse, 

-- exceptions raised - REFERENCE ERROR if no enclosing subprogram can be 

== found or if a label “END” can not be found for 

a an enclosing subprogram. 


function FIND_LOOP_END return SYM_TAB_ ACCESS; 

-- post - A search is conducted to find the enclosing loop 

== of the parse. A pointer to the label "END" for this 

35 enclosing loop is returned. This function is used to 

cag provide the operand for an "exit" statement. The current entry 
ie is the end label corresponding to the enclosing loop of the 

= parse. 

-- exceptions raised - REFERENCE_ERROR if no enclosing loop can be 

=< found or if a label "END" can not be found for 

re an enclosing loop. 


function FIND _TASK_END return SYM_TAB_ACCESS; 

-- post - A search is conducted to find the enclosing task 

St of the parse. A pointer to the label "END" for this 

= enclosing task is returned. The current entry 

= is the end label corresponding to the enclosing task of the 
as parse. 

-- exceptions raised - REFERENCE ERROR if no enclosing task can be 

oo found or if a label "END" can not be found for 
a an enclosing task. 


procedure UPDATE _SYM_TAB(LOCATION : in natural); 
-- pre - The current entry is defined. 
-- post - The current entry's location is changed to LOCATION. 


function SELECT _COMPONENT(KEY : in string) return SYM _TAB_ACCESS; 

-- pre - The current entry is defined. 

-- post - SELECT _COMPONENT provides visibility to the next static nesting 
level below the current entry. If the symbol table contains an 
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a entry whose key value is KEY at the next static nesting level, 
iad then that entry is the current entry and FINO_KEY returns a 

ee pointer to that symbol table record, else FIND_KEY returns 

== a null pointer and the current entry is undefined. NOTE - 

=e the symbol table IS case sensitive in it's comparison of keys. 


function RETRIEVE_SYM return SYM_TAB ACCESS; 
-- post - RETRIEVE_SYM returns a pointer to the current entry or null if 
os the current entry is undefined. 


procedure SAVE CURRENT _ENTRY; 
-- pre - The current entry is defined; 
-- post - The current entry is saved in a last in first out data structure. 


procedure RESTORE_CURRENT ENTRY; 
-- pre - A Current entry was saved; 
-- post - The last current entry saved is the current entry. 


procedure PRINT _SYMBOL_TABLE; 

-- post - Useful as a debugging tool, PRINT _SYMBOL_TABLE prints a dump of 
== every symbol table entry, including attribute and location 

22 information, to the standard output device. 


end SYMBOL_TABLE; 
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—~ — FSS SSS SSF SSS SS SS SS SS SSS SSS SSS SS SSSSSSSFSSSSSSSSSS SESS SSIS SHVSSSVSEV*V*IZF_. 


== SEE: ADAFLOW ae 


-- MODULE NAME: PACKAGE SYMBOL_ TABLE =< 
-- FILE NAME: SYM_TAB.ADB == 


-=- DATE CREATED: 01 MAR 88 aie: 
-- LAST MODIFIED: 28 APR 88 ais 


-- AUTHOR(S): LT ALBERT J. GRECCO, USN oe 


-- DESCRIPTION: This package contains the procedures which is 
= implement the interface to the symbol table. a 


—— SFSFSSSSSSSS SS STS S SSS SSS SSS SSSSSSHESSSSSSESSSESSS SST SSHSSSESHSSHSESS*SGGEW 


with TOKEN SCANNER, 
GENERIC_STACK, 
UNCHECKED _DEALLOCATION, 
TESp eto 


package body SYMBOL_TABLE is 


procedure FREE SYM _REC is new 
UNCHECKED _DEALLOCATION(SYM_TAB_RECORD,SYM_TAB_ACCESS) ; 
subtype DEFINITION_TAGS is SYMBOL_TAG range 
FUNCTION _DECLARATION_TAG. .ENTRY_TAG; 
subtype BODY_TAGS is SYMBOL_TAG range PACKAGE _BODY_TAG. .ACCEPT_TAG; 


type LIST_NODE; 
type LIST_NODE_POINTER is access LIST_NODE; 
package SYMBOL_LIST is 


type LIST_INSTANCE is private; 
type LIST is access LIST_INSTANCE; 


LIST OVERFLOW : exception; 
LIST_UNDERFLOW : exception; 


-- Operations: If the list is not empty, then one of the nodes is designated 
a= as the current node. Ocaasionally, in the postcondition, it is necessary 
=< to refer to the list of the current node as they were immediately before 
a execution of the operation. L-pre and c-pre, respectively, are employed 
= for these references. 


procedure FIND_FIRST(L : in out LIST); 
-- pre - The list L is not empty. 
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-- post - The first node is the current node. 
-- exceptions raised - LIST_UNDERFLOW if L is empty. 


procedure FIND NEXT(L : in out LIST); 

-- pre - The list L 1s not empty and the last node is not the current node. 
-- post - c-next in L is the current node. 

-- exceptions raised - LIST_UNDERFLOW if L is empty. 

== - LIST_OVERFLOW if the last node is the current node. 


procedure FIND PREVIOUS(L : in out LIST); 
-- pre - The list L is not empty and the first node is not the current node. 
-- post - c-prior in L is the current node. 

-- exceptions raised - LIST_UNDERFLOW if L is empty or c is the first node. 


procedure FIND _LAST(L : in out LIST); 

-- pre - The list L is not empty. 

-- post - The last node in L is the current node. 

-- exceptions raised - LIST_UNDERFLOW if L is empty. 


procedure RETRIEVE(L : in LIST; ITEM : out LIST _NODE_POINTER); 

-- pre - The list L is not empty. 

-- post - ITEM contains the value of the element in the current node. 
-- exceptions raised - LIST_UNDERFLOW if L is empty. 


procedure UPDATE(L : in out LIST; ITEM : in LIST_NODE_POINTER) ; 
-- pre - The list L is not empty. 

-- post - The current node in L contains ITEM as its element. 
-- exceptions raised - LIST_UNDERFLOW if L is empty. 


procedure INSERT(L : in out LIST; ITEM : in LIST_NODE_POINTER); 

-- pre - The number of nodes in L has not reached its bound. 

-- post - A node containing ITEM is the last node in the list, and the last 
=S node in L-pre, if any, is its predecessor. The node containing 
ah ITEM is the current node. 

-- exceptions raised - LIST OVERFLOW if L has reached its bound. 


procedure DELETE(L : in out LIST); 

-- pre - The list L is not empty. 

-- post - c-pre in not in the list L. If c-pre was the first node, 

a then c-next, if it exists, is the successor of c-prior. If the 
oo list L is not empty, then the last node is the current node. 

-- exceptions raised - LIST_UNDERFLOW if L is empty. 


function SIZE _OF(L : in LIST) return natural; 
-- post - SIZE_OF is the number of nodes in list L. 


function EMPTY(L : in LIST) return boolean; 


-- post - If the list L has no nodes then EMPTY is true, else EMPTY is 
la false. 
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function 
==" pOSiE = 


function 
=— 00S 


-- excepti 


function 
aD OS ta 


-- excepti 
procedure 


== pOS tar 


procedure 
=> (OSE < 


procedure 
=" OS car. 


procedure 
==) post = 


procedure 
==" post 


private 


type NODE; 


type NODE _ 


type NODE 
record 


FULL(L : in LIST) return boolean; 
If the number of nodes in the list L has reached the maximum 
allowed, then FULL is true, else FULL is false. 


FIRST(L : in LIST) return boolean; 

The list L is not empty. 

If the first node is the current node in L then FIRST is true, else 
FIRST is false. 

ons raised - LIST_UNDERFLOW if L is empty. 


LAST(L : in LIST) return boolean; 

The list L is not empty. 

If the last node is the current node in L then LAST is true, else 
LAST is false. 

ons raised - LIST_UNDERFLOW if L is empty. 


CREATE(L : in out LIST; SUCCESS : out boolean); 
If a list L can be created then L exists and is empty, and SUCCESS 
is TRUE else SUCCESS is FALSE. 


DISPOSE(L : in out LIST); 
L-pre does not exist. 


ASSIGN(LY 2 an Lisl; (&2 in out Ishi: 
L2 contains the same nodes as L1. 


SAVE LISTOCESs. aneGisly: 
L is saved in a last in first out data structure. 


RESTORE _LISTOG ine out CIST ); 
L is the last list that was saved. 


POINTER is access NODE; 
is 


ELEMENT : LIST_NODE_POINTER; 


NEXT 


: NODE POINTER; 


end record; 


type LIST_ 


record 
HEAD 
TAIL 


INSTANCE is 
NODE_POINTER := null; 
: NODE_POINTER := null; 
CURRENT : NODE POINTER := null; 


STZE 


natural := 0; 


end record; 


end SYMBOL LIST: 
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type LIST_NODE is 


record 
SYMBOL : SYM_TAB_ACCESS; 
SUB_LIST : SYMBOL_LIST.LIST; 


end record; 


SYM_TAB : SYMBOL_LIST.LIST; -- the root of the symbol table tree 
CURRENT_SNL : SYMBOL_LIST.LIST; -- keeps track of the current branch 
SEARCH_SNL : SYMBOL_LIST.LIST; -- can be operated on without effecting 


-- the state of the symbol table. 
LAST_FOUND : LIST_NODE_POINTER := null; 
package STK_OF_LISTS is new GENERIC_STACK(SYMBOL_LIST.LIST); 
SCOPE_STACK : STK_OF_LISTS.STACK; 
package body SYMBOL_LIST is 


procedure FREE NODE is new UNCHECKED DEALLOCATION(NODE, NODE_POINTER); 
procedure FREE_LIST is new UNCHECKED DEALLOCATION(LIST_INSTANCE, LIST); 
procedure FREE_SYM_REC is new 

UNCHECKED _DEALLOCATION(SYM_TAB_RECORD,SYM_TAB_ACCESS) ; 
package STACK_LIST_INSTANCES is new GENERIC_STACK(LIST); 


SLI : STACK_LIST_INSTANCES. STACK; 
SUCCESS : boolean; 


procedure FINO _FIRST(L : in out LIST) is 
-- pre - The list L is not empty. 
-- post - The first node is the current node. 
-- exceptions raised - LIST_UNDERFLOW if L is empty. 
begin 

if (EMPTY(L)) then 

raise LIST_UNDERFLOW; 

end if; 

L.CURRENT := L.HEAD; 
end FIND FIRST; 


procedure FIND_NEXT(L : in out LIST) is 
-- pre - The list L is not empty and the last node is not the current node. 
-- post - c-next in L is the current node. 
-- exceptions raised - LIST_UNDERFLOW if L is empty. 
= - LIST_OVERFLOW if the last node is the current node. 
begin 
if (EMPTY(L)) then 
raise LIST_UNDERFLOW; 
enGment.: 
if (LAST(L)) then 
raise LIST OVERFLOW; 
end if; 


183 


L.CURRENT := L.CURRENT.NEXT; 
end FIND NEXT; 


procedure FIND PREVIOUS(L : in out LIST) is 
-- pre - The list L is not empty and the first node is not the current node. 
-- post - c-prior in L 1s the current node. 
~- exceptions raised - LIST_UNDERFLOW if L is empty or c is the first node. 
TEMP_POINTER : NODE_POINTER; 
begin 
if (EMPTY(L) or FIRST(L)) then 
raise LIST _UNDERFLOw; 
end if; 
TEMP_POINTER := L.HEAD; 
while (TEMP_POINTER.NEXT /= L.CURRENT) loop 
TEMP_POINTER := TEMP_POINTER.NEXT; 
end loop; 
L.CURRENT := TEMP_POINTER; 
end FINO PREVIOUS; 


procedure FIND _LAST(L : in out LIST) is 
-- pre - The list L is not empty. 
-- post - The last node in L is the current node. 
-- exceptions raised - LIST_UNDERFLOW if L is empty. 
begin 
if (EMPTY(L)) then 
raise LIST_UNDERFLOW; 
end if; 
while (not LAST(L)) loop 
FIND _NEXT(L); 
end loop; 
end FINO_LAST; 


procedure RETRIEVE(L : in LIST; ITEM : out LIST_NODE_POINTER) is 
-- pre - The list L is not empty. 
-- post - ITEM contains the value of the element in the current node. 
-- exceptions raised - LIST_UNDERFLOW if L is empty. 
begin 

if (EMPTY(L)) then 

raise LIST_UNDERFLOW; 

end if; 

ITEM := L.CURRENT.ELEMENT; 
end RETRIEVE; 


procedure UPDATE(L : in out LIST; ITEM : in LIST_NODE POINTER) is 
-- pre - The list L iS not empty. 
-- post - The current node in L contains ITEM as its element. 
-- exceptions raised - LIST_UNDERFLOW if L is empty. 
begin 

if (EMPTY(L)) then 

raise LIST UNDERFLOW; 
end if; 
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L.CURRENT.ELEMENT := ITEM; 
end UPDATE; 


procedure INSERT(L : in out LIST; ITEM : in LIST_NODE POINTER) is 
-- pre - The number of nodes in L has not reached its bound. 
-- post - A node containing ITEM is the last node in the list, and the last 
ie node in L-pre, if any, iS itS predecessor. The node containing 
ae ITEM is the current node. 
-- exceptions raised - LIST_OVERFLOW if L has reached its bound. 
TEMP_POINTER : NODE_POINTER; 
begin 
if (FULL(L)) then 
raise LIST OVERFLOW; 
end if; 
TEMP_POINTER := new NODE'( ITEM, null); 
TEMP_POINTER.ELEMENT .SYMBOL.REFERENCE COUNT := 
natural 'SUCC( TEMP POINTER.ELEMENT .SYMBOL .REFERENCE COUNT); 
if (L.HEAD = null) then 
L.HEAD := TEMP_POINTER; 
L.TAIL := TEMP_POINTER; 


else 
L.TAIL.NEXT := TEMP_POINTER; 
L.TAIL := TEMP_POINTER; 
end if; 


L.CURRENT := TEMP POINTER; 
L.SIZE := L.SIZE + 1; 
end INSERT; 


procedure DELETE(L : in out LIST) 1s 
-- pre - The list L is not empty. 
-- post - cC-pre in not in the list L. If c-pre was the first node, 
a then c-next, if it exists, is the successor of c-prior. If the 
oS list L iS not empty, then the last node is the current node. 
-- exceptions raised - LIST_UNDERFLOW if L is empty. 
TEMP_POINTER : NODE POINTER; 
begin 
if (EMPTY(L)) then 
raise LIST _UNDERFLOW; 
end if; 
if (L.CURRENT /= L.HEAD) then 
TEMP POINTER := L.HEAD; 
while (TEMP_POINTER.NEXT /= L.CURRENT) loop 
TEMP_POINTER := TEMP POINTER.NEXT; 
end loop; 
TEMP_POINTER.NEXT := L.CURRENT NEXT; 
if (L.CURRENT = L.TAIL) then 
L.TAIL := TEMP POINTER; 
end if; 
else 
if (L.HEAD = L.TAIL) then 
een AT eee senile 
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end if; 
L.HEAD := L.HEAD.NEXT; 
end if; 
if (L.CURRENT.ELEMENT.SYMBOL.REFERENCE COUNT > 1) then 
L.CURRENT .ELEMENT.SYMBOL.REFERENCE COUNT := 
positive’ PREO(L.CURRENT.ELEMENT .SYMBOL .REFERENCE COUNT ); 
else 
FREE_SYM_REC(L.CURRENT.ELEMENT .SYMBOL ); 
end if; 
OISPOSE(L.CURRENT .ELEMENT.SUB LIST); 
FREE_NODE(L.CURRENT) ; 
L.CURRENT := L.TAIL; 
aside ge (Losvvds = ie 
end DELETE; 


function SIZE_OF(L : in LIST) return natural is 
-- post - SIZE_OF is the number of nodes in list lL. 
begin 
return (L.SIZE); 
end SIZE_OF; 


function EMPTY(L : in LIST) return boolean is 
-- post - If the list L has no nodes then EMPTY is true, else EMPTY is 
a false. 
begin 
return (L.HEAD = null); 
end EMPTY; 


function FULL(L : in LIST) return boolean is 
-- post - If the number of nodes in the list L has reached the maximum 
a= allowed, then FULL is true, else FULL is false. 
TEMP_POINTER : NODE_POINTER; 
begin 
TEMP_POINTER := new NODE; 
FREE_NODE( TEMP POINTER); 
return (FALSE); 
exception 
when STORAGE _ERROR => 
return (TRUE); 
when others => 
raise; 
end FULL; 


function FIRST(L : in LIST) return boolean is 
-- pre - The list L is not empty. 
-- post - If the first node is the current node in L then FIRST is true, else 
= FIRST is false: 
-- exceptions raised - LIST_UNDERFLOW if L is empty. 
begin 
if (EMPTY(L)) then 
raise LIST _UNDERFLOW; 
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end if; 
return (L.CURRENT = L.HEAD); 
end FIRST; 


function LAST(L : in LIST) return boolean is 
-- pre - The list L is not empty. 
-- post - If the last node is the current node in L then LAST is true, else 
=e LAST is false. 
-- exceptions raised - LIST_UNDERFLOW if L is empty. 
begin 

if (EMPTY(L)) then 

raise LIST_UNDERFLOW; 

end if; 

return (L.CURRENT = L.TAIL); 
end LAST; 


procedure CREATE(L : in out LIST; SUCCESS : out boolean) is 
-- post - If a list L can be created then L exists and is empty, and SUCCESS 
as is TRUE else SUCCESS is FALSE. 
begin 
L := new LIST_INSTANCE'(null, null, null, 0); 
SUCCESS := TRUE; 
exception 
when STORAGE ERROR => 
SUCCESS := FALSE; 
when others => 
raise; 
end CREATE; 


procedure DISPOSE(L : in out LIST) is 
-- post - L-pre does not exist. 
begin 
if (not EMPTY(L)) then 
FIND _LAST(L); 
while (not EMPTY(L)) loop 
DECETE(L); 
end loop; 
end if; 
FREE_LIST(L); 
end DISPOSE; 


procedure ASSIGN(L1 : in LIST; L2 : in out LIST) is 
-- post - L2 contains the same nodes as L1. 


begin 
L2.HEAD = EL HEAD: 
L2.CURRENT := L1.CURRENT; 
L2.TAIL = L1.TAIL; 
L2.SIZE =I SIZE: 


end ASSIGN; 


187 


procedure SAVE _LIST(L : in LIST) 1s 
-- post - L is saved in a last in first out data structure. 
TEMPLES). EtSte 
SUCCESS : boolean; 
begin 

CREATE(TEMP_LIST, SUCCESS); 

if (not SUCCESS) then 

raise SYMBOL_TABLE_OVERFLOW; 

end if; 

ASSIGN(L, TEMP_LIST); 

STACK_LIST_INSTANCES.PUSH(SLI, TEMP_LIST); 
end SAVE_LIST; 


procedure RESTORE_LIST(L : in out LIST) is 
-- post - L is the last list that was saved. 
TEMPCLIST =: -ENStT; 
begin 
STACK_LIST_INSTANCES.POP(SLI, TEMP_LIST); 
ASSIGN(TEMP_LIST, L); 
FREE_LIST(TEMP_LIST); 
end RESTORE_LIST; 


begin 
STACK_LIST_INSTANCES.CREATE(SLI, SUCCESS); 
if (not SUCCESS) then 
raise SYMBOL_TABLE_OVERFLOW; 
end if; 
end SYMBOL LIST; 


function SNL_SEARCH(KEY : 1n string) return LIST NODE _POINTER is 
-- post - If the symbol table contains an entry at the local scope whose 
—— key value is KEY, then that entry is the current entry in the 
a list SEARCH SNL and SNL_SEARCH returns a pointer to that list 
a node, else SNL SEARCH returns a null pointer and the 
tee current entry in the list SEARCH SNL is the last entry. 
SEARCH _POINTER : LIST _NODE_POINTER; 
begin 
if (SYMBOL_LIST.EMPTY(SEARCH_SNL)) then 
return (null); 
else 
SYMBOL_LIST.FIND_FIRST(SEARCH_SNL); 
loop 
SYMBOL_LIST.RETRIEVE(SEARCH SNL, SEARCH POINTER); 
if ((SEARCH_POINTER.SYMBOL.NAME_ LENGTH = KEY'LENGTH) and then 
(SEARCH_POINTER.SYMBOL.NAME(1..KEY'LAST) = KEY)) then 
return (SEARCH POINTER); 
else 
exit when (SYMBOL_LIST.LAST( SEARCH SNL)); 
SYMBOL_LIST. FIND NEXT(SEARCH_SNL); 
end if; 
end Joop; 
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return (null); 
end if; 
end SNL_SEARCH; 


procedure INITIALIZE SYM_TAB is 
-- post - SYM_TAB contains the names and defined attributes for the language 
oe defined enclosing scopes. 
SUCCESS : boolean; 
begin 
SYMBOL_LIST.CREATE(SYM_TAB, SUCCESS); 
if (not SUCCESS) then 
raise SYMBOL_TABLE_OVERFLOW; 
end if; 
SYMBOL_LIST.CREATE(SEARCH_SNL, SUCCESS); 
if (not SUCCESS) then 
raise SYMBOL_TABLE_OVERFLOW; 
end if; 
STK_OF_LISTS.CREATE(SCOPE_STACK, SUCCESS); 
if (not SUCCESS) then 
raise SYMBOL_TABLE_ OVERFLOW; 
end if; 
CURRENT_SNL := SYM_TAB; 
end INITIALIZE_SYM_TAB; 


procedure CLEAR _SYM_TAB is 
-- post - SYM_TAB is returned to it’s initialized state. 
SUCCESS : boolean; 
begin 
SYMBOL_LIST.DISPOSE(SYM_TAB); 
STK_OF_LISTS.DISPOSE(SCOPE STACK); 
SYMBOL_LIST.CREATE(SYM_TAB, SUCCESS); 
if (not SUCCESS) then 
raise SYMBOL_TABLE_ OVERFLOW; 
end if; 
aI KOORSLISTS.CREATE(SCOPE_STACK, SUCCESS); 
if (not SUCCESS) then 
raise SYMBOL_TABLE_OVERFLOW; 
end if; 
CURRENT_SNL := SYM _TAB; 
LAST_FOUND := null; 
end CLEAR_SYM_TAB; 


function FULL SYM TAB return boolean is 
-- post - If the size of SYM _TAB has not reached its bound then FULL is 
= FALSE else FULL is TRUE. 
begin 
return (SYMBOL_LIST.FULL(CURRENT SNL )); 
end FULL _SYM TAB; 


procedure ENTER SCOPE is 
~- post - SYM TAB enters the next Static nesting level. 
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TEMP_POINTER : LIST_NODE_POINTER; 

begin 
STK_OF_LISTS.PUSH(SCOPE_STACK, CURRENT_SNL); 
SYMBOL_LIST.RETRIEVE(SEARCH_SNL, TEMP_POINTER); 
CURRENT_SNL := TEMP_POINTER.SUB_LIST; 
SYMBOL_LIST.ASSIGN(CURRENT_SNL, SEARCH_SNL); 

end ENTER_SCOPE; 


procedure ENTER SEARCH SCOPE is 
-- post - SYM_TAB enters the next static nesting level. 
TEMP POINTER : LIST_NODE_POINTER; 
begin 
SYMBOL_LIST.RETRIEVE(SEARCH_SNL, TEMP_POINTER); 
SYMBOL_LIST.ASSIGN(TEMP_POINTER.SUB_LIST, SEARCH SNL); 
end ENTER _SEARCH_SCOPE; 


procedure EXIT SCOPE is 

-- post - SYM_TAB backs up one static nesting level. The current entry is 

i defined as the entry that caused the corresponding scope entry to 

= occur. 

TEMP_POINTER : LIST_NODE_POINTER; 

begin 
STK_OF_LISTS.POP(SCOPE_STACK, CURRENT_SNL); 
SYMBOL_LIST.ASSIGN(CURRENT_SNL, SEARCH_SNL); 
SYMBOL_LIST.RETRIEVE(SEARCH_ SNL, LAST_FOUND) ; 

end EXIT SCOPE; 


procedure INSERT_SYM_TAB(KEY > in string; 
ATTRIBUTE : in SYMBOL_TAG; 
LOCATION : in natural) is 

-- pre - SYM_TAB has not achieved its maximum allowable size. 
-- post - If the ATTRUBUTE is OBJECT _DECLARATION_TAG, TYPE_CECLARATION_TAG, 
= or LABEL_NAME, a search is conducted at the local SNL for a 
a matching KEY. If no match is found, KEY is inserted with the given 
me attribute and location and is the the current entry, else no 
i action is taken and the current entry is the pre-existing entry 
os named by key. 
— If the ATTRIBUTE is FUNCTION DECLARATION_TAG, 
-- PROCEDURE DECLARATION_TAG, PACKAGE_DECLARATION_TAG, 
=e TASK_DECLARATION_TAG, or ENTRY_TAG, a search is conducted at the 
== local SNL for a matching KEY. If no match is found, KEY is inserted 
a with the given attribute and location and scope entry occurs, else 
== a check is made to see if the pre-existing entry is a 
— PROCEDURE_DECLARATION_TAG or a FUNCTION DECLARATION TAG. If so, 
ae location is updated and scope entry occurs. 

a) If the ATTRIBUTE 1s PACKAGE BODY_TAG, TASK _BODY_TAG, or 

a ACCEPT_TAG, the corresponding environment of definition is 
a located, the location updated, and then scope entry occurs. 
as If the ATTRIBUTE 1s LOOP_TAG or SELECT_TAG, the symbol is entered 
= with the given ATTRIBUTE and LOCATION and scope entry occurs. 

- exceptions raised - SYMBOL TABLE OVERFLOW if the symbol table's size 
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= has reached it's bound. 

-- DECLARATION_ERROR if the required environment of 

ac definition can not be found for a body declaration 

“= or if a declaration tag already exists at the current 


-- SNL. 

TEMP POINTER : LIST NODE POINTER; 
SEARCH POINTER : LIST_NODE_ POINTER; 
TEMP_ SYMBOL : SYM_TAB_ACCESS; 


SUCCESS : boolean; 
use SYMBOL_LIST; 
begin 
if ((ATTRIBUTE = OBJECT _DECLARATION_TAG) or else 
(ATTRIBUTE = TYPE _DECLARATION_TAG) or else (ATTRIBUTE = LABEL _NAME)) then 
SYMBOL_LIST.ASSIGN(CURRENT_SNL, SEARCH_SNL); 
SEARCH_POINTER := SNL_SEARCH(KEY); 
if (SEARCH POINTER = null) then 
if (mot SYMBOL_LIST.FULL(CURRENT_SNL)) then 
TEMP_POINTER := new LIST _NODE; 
TEMP_POINTER.SYMBOL := new SYM_TAB_RECORD; 
TEMP_POINTER.SYMBOL.NAME_LENGTH := KEY’LENGTH; 
TEMP_POINTER.SYMBOL.NAME := (others => ' '); 
TEMP_POINTER.SYMBOL .NAME(1..KEY'LAST) := KEY; 
TEMP_POINTER.SYMBOL.TAG_TYPE := ATTRIBUTE; 
TEMP_POINTER.SYMBOL .LOCATION := LOCATION; 
_TEMP_POINTER.SYMBOL.REFERENCE_COUNT := 0; 
SYMBOL_LIST.CREATE(TEMP_POINTER.SUB_LIST, SUCCESS); 
if (mot SUCCESS) then 
raise SYMBOL_TABLE_OVERFLOW; 
end if; 
SYMBOL_LIST.INSERT(CURRENT_SNL, TEMP POINTER); 
SYMBOL_LIST.ASSIGN(CURRENT_SNL, SEARCH SNL); 
LAST_FOUND := TEMP_POINTER; 
else 
raise SYMBOL_TABLE_OVERFLOW; 
end if; 
else 
SYMBOL_LIST.ASSIGN(CURRENT SNL, SEARCH_SNL); 
LAST_FOUND := SEARCH POINTER; 
end if; 
elsif (ATTRIBUTE in DEFINITION TAGS) then 
SYMBOL_LIST.ASSIGN(CURRENT_ SNL, SEARCH_SNL); 
SEARCH POINTER := SNL_SEARCH( KEY); 
if (SEARCH POINTER = null) then 
if (mot SYMBOL_LIST.FULL(CURRENT SNL)) then 
TEMP POINTER := new LIST NODE; 
TEMP _POINTER.SYMBOL := new SYM_TAB_ RECORD; 
TEMP_POINTER.SYMBOL .NAME_LENGTH := KEY'LENGTH; 
TEMP_POINTER.SYMBOL.NAME := (others => ’ '); 
TEMP_POINTER.SYMBOL .NAME(1..KEY’LAST) := KEY; 
TEMP_POINTER.SYMBOL.TAG_TYPE := ATTRIBUTE; 
TEMP _POINTER.SYMBOL.LOCATION := LOCATION; 
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TEMP _POINTER.SYMBOL.REFERENCE COUNT := 0; 
SYMBOL_LIST.CREATE(TEMP_POINTER.SUB LIST, SUCCESS); 
if (not SUCCESS) then 

raise SYMBOL_TABLE_OVERFLOW; 
end if; 
SYMBOL_LIST.INSERT(CURRENT_SNL, TEMP_POINTER); 
SYMBOL_LIST.ASSIGN(CURRENT_SNL, SEARCH_SNL); 
LAST_FOUND := TEMP POINTER; 
ENTER SCOPE; 


else 
raise SYMBOL_TABLE_OVERFLOW; 
end if; 
elsif ((ATTRIBUTE = FUNCTION _DECLARATION_TAG) or 
(ATTRIBUTE = PROCEDURE _DECLARATION_TAG)) then 


UPDATE_SYM_TAB( LOCATION); 
SYMBOL_LIST.ASSIGN(SEARCH_SNL, CURRENT_SNL); 
LAST_FOUND := SEARCH_POINTER; 
ENTER_SCOPE ; 

else 
raise DECLARATION_ERROR; 

end if; 

elsif (ATTRIBUTE in BODY _TAGS) then 

SYMBOL_LIST.ASSIGM(CURRENT_SNL, SEARCH_SNL); 

TEMP_SYMBOL := FIND_KEY(KEY); 

if (TEMP_SYMBOL = null) then 
LAST_FOUND := null; 
raise DECLARATION_ERROR; 

else 
UPDATE SYM _TAB( LOCATION); 
if (SEARCH _SNL = CURRENT_SNL) then 

SYMBOL_LIST.ASSIGN(SEARCH_ SNL, CURRENT_SNL); 

end if; 
SYMBOL_LIST.RETRIEVE(SEARCH_SNL, LAST FOUND); 
ENTER _SCOPE; 

end if; 

elsif (({ATTRIBUTE = LOOP_TAG) or else (ATTRIBUTE = SELECT _TAG)) then 

if (not SYMBOL_LIST.FULL({CURRENT SNL)) then 
TEMP_POINTER := new LIST_NODE; 
TEMP_POINTER.SYMBOL := new SYM_TAB_RECORD; 
TEMP_POINTER.SYMBOL.NAME_LENGTH := KEY'LENGTH; 
TEMP_POINTER.SYMBOL .NAME := (others => ' '); 
TEMP_POINTER.SYMBOL .NAME(1..KEY’LAST) := KEY; 
TEMP_POINTER.SYMBOL .TAG_TYPE ATTRIBUTE; 
TEMP_POINTER.SYMBOL.LOCATION := LOCATION; 
TEMP_POINTER.SYMBOL.REFERENCE_COUNT := 0; 
SYMBOL_LIST.CREATE(TEMP_POINTER.SUB LIST, SUCCESS); 
if (not SUCCESS) then 

raise SYMBOL_TABLE OVERFLOW; 

end if; 
SYMBOL_LIST.INSERT(CURRENT SNL, TEMP POINTER); 
SYMBOL _LIST.ASSIGN( CURRENT SNL, SEARCH SNL); 
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LAST_FOUND := TEMP POINTER; 
ENTER SCOPE ; 
else 
raise SYMBOL_TABLE_OVERFLOW; 
end if; 
end if; 
exception 
when STORAGE ERROR => 
raise SYMBOL_TABLE_ OVERFLOW; 
when others => 
raise; 
end INSERT_SYM_TAB; 


function FIND_KEY(KEY : in string) return SYM _TAB_ACCESS is 
-- post - If the symbol table contains an entry whose key value is KEY, 
os then that entry is the current entry and FINO_KEY returns a 
= pointer to that symbol table record, else FINO_KEY returns 
a a null pointer and the current entry is undefined. NOTE - 
a the symbol table IS case sensitive in it's comparison of keys and 
== the search is global in scope according to ADA visibility rules. 
TEMP_POINTER : LIST_NODE_POINTER; 
TEMP_LIST : SYMBOL_LIST.LIST; 
SEARCH STACK : STK_OF_LISTS.STACK; 
SUCCESS : boolean; 
begin 
STK_OF_LISTS.CREATE( SEARCH STACK, SUCCESS); 
if (not SUCCESS) then 
raise SYMBOL_TABLE_OVERFLOW; 
end if; 
SYMBOL_LIST.ASSIGN(CURRENT_SNL, SEARCH_SNL); 
TEMP_POINTER := SNL_SEARCH( KEY); 
if (TEMP_POINTER /= null) then 
LAST_FOUND := TEMP _POINTER; 
return (TEMP_POINTER.SYMBOL ); 
else 
while (not STK_OF_LISTS.EMPTY(SCOPE_STACK)) loop 
STK_OF_LISTS.POP( SCOPE STACK, TEMP_LIST); 
STK_OF_LISTS.PUSH( SEARCH STACK, TEMP LIST); 
SYMBOL_LIST.ASSIGN(TEMP_LIST, SEARCH SNL); 
TEMP_POINTER := SNL_SEARCH(KEY); 
if (TEMP_POINTER /= null) then 
while (not STK_OF_LISTS.EMPTY(SEARCH STACK)) loop 
STK_OF_LISTS.POP(SEARCH STACK, TEMP_LIST); 
STK_OF_LISTS.PUSH(SCOPE_STACK, TEMP_LIST); 
end loop; 
LAST_FOUND := TEMP_POINTER; 
return (TEMP_POINTER.SYMBOL ); 
end if; 
end loop; 
while (not STK_OF LISTS.EMPTY( SEARCH STACK)) loop 
STK_OF_LISTS.POP({SEARCH_STACK, TEMP_LIST); 
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STK_OF LISTS.PUSH(SCOPE STACK, TEMP_LIST); 
end loop; 
LAST FOUND := null; 
return (null); 
end if; 
end FIND _KEY; 


function FIND LOCAL_KEY(KEY : in string) return SYM _TAB_ACCESS is 
-- post - If the symbol table contains an entry whose key value is KEY, 
Se then that entry is the current entry and FIND_KEY returns a 
= pointer to that symbol table record, else FIND_KEY returns 
So a null pointer and the current entry is undefined. NOTE - 
== the symbol table IS case sensitive in it's comparison of keys and 
ss the search is local in scope according to ADA visibility rules. 
TEMP_POINTER : LIST_NODE_POINTER; 
begin 
SYMBOL _LIST.ASSIGN(CURRENT_ SNL, SEARCH_SNL); 
TEMP POINTER := SNL_SEARCH(KEY); 
if (TEMP POINTER /= null) then 
SYMBOL_LIST.ASSIGN(SEARCH_SNL, CURRENT_SNL); 
LAST FOUND := TEMP POINTER; 
return (TEMP POINTER.SYMBOL ); 
else 
LAST_FOUND := null; 
return (null); 
end if; 
end FIND _LOCAL_KEY; 


function FIND SUBPROGRAM END return SYM_TAB_ACCESS is 
-- post - A search is conducted to find the parent enclosing subprogram 
== of the parse. A pointer to the tabel "END" for this parent 
Se enclosing subprogram is returned. This function is used to 
ae provide the operand for a "return" statement. The current entry 
a is the end label corresponding to the enclosing subprogram of the 
== parse. 
-- exceptions raised - REFERENCE ERROR if no enclosing subprogram can be 
ae found or if a Jabelt "END" can not be found for 
oi an enclosing Subprogram. 
PARENT : LIST_NODE POINTER; 
TEMP LIST : SYMBOL_LIST.LIST; 
SEARCH_STACK : STK_OF _LISTS.STACK; 
SUCCESS : boolean; 
begin 
STK OF _LISTS.CREATE( SEARCH STACK, SUCCESS); 
if (not SUCCESS) then 
raise SYMBOL_TABLE OVERFLOW; 
end if; 
SYMBOL_LIST.ASSIGN(CURRENT SNL, SEARCH SNL); 
if (not STK_OF_LISTS.EMPTY( SCOPE STACK)) then 
STK OF LISTS.POP( SCOPE STACK, TEMP LIST); 
STK OF LISTS.PUSH(SEARCH STACK, TEMP_LIST); 
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SYMBOL_LIST.ASSIGN(TEMP_LIST, SEARCH_SNL); 

SYMBOL_LIST.RETRIEVE(SEARCH SNL, PARENT); 

while ((PARENT.SYMBOL.TAG_TYPE /= FUNCTION DECLARATION_TAG) and then 

(PARENT .SYMBOL.TAG_TYPE /= PROCEDURE _DECLARATION_TAG)) loop 
if (STK_OF_LISTS.EMPTY(SCOPE_STACK)) then 

raise REFERENCE ERROR; 

end if; 
STK_OF_LISTS.POP(SCOPE_ STACK, TEMP _LIST); 
STK_OF_LISTS.PUSH(SEARCH_STACK, TEMP_LIST); 
SYMBOL_LIST.ASSIGN( TEMP_LIST, SEARCH_SNL); 
SYMBOL_LIST.RETRIEVE(SEARCH_SNL, PARENT); 

end loop; 

while (not STK_OF_LISTS.EMPTY(SEARCH_STACK)) loop 
STK_OF_LISTS.POP( SEARCH STACK, TEMP_LIST); 
STK_OF_LISTS.PUSH( SCOPE STACK, TEMP_LIST); 

end loop; 

SYMBOL _LIST.ASSIGN( PARENT .SUB_LIST, SEARCH_SNL); 

PARENT := SNL_SEARCH("END"); 

if (PARENT /= null) then 
LAST_FOUND := PARENT; 
return (PARENT .SYMBOL); 

else 
raise REFERENCE ERROR; 

end if; 

else 
raise REFERENCE ERROR; 
end if; 
end FIND _SUBPROGRAM_END; 


function FIND_LOOP_END return SYM_TAB_ACCESS is 
-- post - A search is conducted to find the enclosing loop 
a of the parse. A pointer to the label "END" for this 
aa enclosing loop is returned. This function is used to 
== provide the operand for an "exit" statement. The current entry 
== is the end label corresponding to the enclosing loop of the 
a parse. 
-- exceptions raised - REFERENCE _ERROR if no enclosing loop can be 
=o found or if a label "END" can not be found for 
=e an enclosing loop. 
PARENT : LIST_NODE_POINTER; 
PemeetIsSt : SYMBOL_LIST.LIST; 
SEARCH_STACK : STK_OF_LISTS.STACK; 
SUCCESS : boolean; 
begin 

STK_OF LISTS.CREATE( SEARCH STACK, SUCCESS); 

if (not SUCCESS) then 

raise SYMBOL_TABLE OVERFLOW; 

end if; 

SYMBOL_LIST.ASSIGN(CURRENT SNL, SEARCH_SNL); 

if (not STK_OF_LISTS.EMPTY(SCOPE STACK)) then 

STK OF _LISTS.POP(SCOPE STACK, TEMP LIST); 
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STK_OF_LISTS.PUSH(SEARCH_STACK, TEMP_LIST); 

SYMBOL_LIST.ASSIGN( TEMP_LIST, SEARCH SNL); 

SYMBOL_LIST.RETRIEVE( SEARCH SNL, PARENT); 

while (PARENT.SYMBOL.TAG_TYPE /= LOOP_TAG) loop 
if (STK_OF_LISTS.EMPTY(SCOPE_STACK)) then 

raise REFERENCE ERROR; 

end if; 
STK_OF_LISTS.POP( SCOPE STACK, TEMP_LIST); 
STK_OF_LISTS.PUSH( SEARCH STACK, TEMP_LIST); 
SYMBOL_LIST.ASSIGN( TEMP_LIST, SEARCH_SNL); 
SYMBOL_LIST.RETRIEVE(SEARCH_SNL, PARENT); 

end loop; 

while (not STK_OF_LISTS.EMPTY(SEARCH_STACK)) loop 
STK_OF_LISTS.POP( SEARCH STACK, TEMP_LIST); 
STK_OF_LISTS.PUSH(SCOPE_STACK, TEMP_LIST); 

end loop; 

SYMBOL_LIST.ASSIGN( PARENT .SUB_LIST, SEARCH_SNL); 

PARENT := SNL_SEARCH("END"); 

if (PARENT /= null) then 
LAST_FOUND := PARENT; 
return (PARENT.SYMBOL); 

else 
raise REFERENCE_ERROR; 

end if; 

else 
raise REFERENCE ERROR; 
end if; 
end FIND_LOOP_END; 


function FIND _TASK_END return SYM_TAB_ACCESS is 
-- post - A search is Conducted to find the enclosing task 
= of the parse. A pointer to the label "END" for this 
os enclosing task is returned. The current entry 
-- is the end label corresponding to the enclosing task of the 
= parse. 
-- exceptions raised - REFERENCE_ERROR if no enclosing task can be 
== found or if a label "END" can not be found for 
== an enclosing task. 
PARENT : LIST _NODE_POINTER; 
TEMP_LIST + -SYMBOL_LIST- LIST; 
SEARCH_STACK : STK_OF_LISTS.STACK; 
SUCCESS : boolean; 
begin 
STK_OF _LISTS.CREATE( SEARCH STACK, SUCCESS); 
if (not SUCCESS) then 
raise SYMBOL_TABLE OVERFLOW; 
end if; 
SYMBOL_LIST.ASSIGN(CURRENT SNL, SEARCH_SNL); 
if (not STK_OF_LISTS.EMPTY(SCOPE _STACK)) then 
STK_OF _LISTS.POP(SCOPE STACK, TEMP LIST); 
STK_OF_LISTS.PUSH( SEARCH STACK, TEMP LIST); 


196 


SYMBOL_LIST.ASSIGN(TEMP_LIST, SEARCH_SNL); 

SYMBOL_LIST.RETRIEVE(SEARCH_SNL, PARENT); 

while (PARENT.SYMBOL.TAG_TYPE /= TASK_DECLARATION_TAG) loop 
if (STK_OF_LISTS.EMPTY(SCOPE_STACK)) then 

raise REFERENCE ERROR; 

end if; 
STK_OF_LISTS.POP(SCOPE_STACK, TEMP_LIST); 
STK_OF_LISTS.PUSH(SEARCH_STACK, TEMP_LIST); 
SYMBOL_LIST.ASSIGN( TEMP_LIST, SEARCH_SNL); 
SYMBOL_LIST.RETRIEVE(SEARCH_SNL, PARENT); 

end loop; 

while (not STK_OF_LISTS.EMPTY(SEARCH_STACK)) loop 
STK_OF_LISTS.POP(SEARCH_ STACK, TEMP_LIST); 
STK_OF_LISTS.PUSH(SCOPE_STACK, TEMP_LIST); 

end loop; 

SYMBOL_LIST.ASSIGN(PARENT.SUB_LIST, SEARCH_SNL); 

PARENT := SNL_SEARCH("END"); 

if (PARENT /= null) then 
LAST_FOUND := PARENT; 
return (PARENT.SYMBOL ); 

else 
raise REFERENCE ERROR; 

end if; 

else 
raise REFERENCE ERROR; 
end if; 
end FIND_TASK_END; 


procedure UPDATE_SYM _TAB(LOCATION : in natural) is 

-- pre - The current entry is defined. 

-- post - The current entry's location is changed to LOCATION. 

TEMP POINTER : LIST_NODE_POINTER; 

begin 
SYMBOL_LIST.RETRIEVE(SEARCH_SNL, TEMP_POINTER); 
TEMP_POINTER.SYMBOL ..LOCATION := LOCATION; 
SYMBOL_LIST.UPDATE(SEARCH_SNL, TEMP_POINTER); 

end UPDATE_SYM_TAB; 


function SELECT_COMPONENT(KEY : in string) return SYM_TAB_ACCESS is 
-- pre - FIND_KEY or SELECT_COMPONENT returns a non-null value. 
-- post - SELECT _COMPONENT provides visibility to the next static nesting 
aS level below the current entry. 
— If the symbol table contains an entry whose key value is KEY, 
=" then that entry is the current entry and FIND _KEY returns a 
== pointer to that symbol table record, else FIND _KEY returns 
aoa a null pointer and the current entry is undefined. NOTE - 
2s The symbol table IS case sensitive in it's comparison of keys. 
TEMP POINTER : LIST NODE POINTER; 
begin 
ENTER _SEARCH_ SCOPE ; 
TEMP_POINTER := SNL SEARCH( KEY); 
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if (TEMP_POINTER = null) then 
LAST_FOUND := null; 
return (null); 

else 
LAST_FOUND := TEMP_POINTER; 
return (TEMP_POINTER.SYMBOL ) ; 

end if; 

end SELECT COMPONENT; 


function RETRIEVE_SYM return SYM_TAB_ACCESS is 
-- post - RETRIEVE SYM returns a pointer to the current entry or null if 
aia the current entry is undefined. 
TEMP_POINTER : LIST_NODE_POINTER; 
begin 
if (LAST_FOUND /= nuit) then 
return (LAST_FOUND.SYMBOL); — 
else 
return (null); 
end if; 
end RETRIEVE SYM; 


procedure SAVE _CURRENT_ENTRY is 
-- pre - The current entry is defined; 
-- post - The current entry is saved in a last in first out data structure. 
begin 
SYMBOL_LIST.SAVE_LIST(SEARCH_SNL); 
end SAVE CURRENT ENTRY; 


procedure RESTORE_CURRENT_ENTRY is 
-- pre - A current entry was saved; 
-- post - The last current entry saved is the current entry. 
begin 
SYMBOL_LIST.RESTORE_LIST( SEARCH SNL); 
SYMBOL_LIST.RETRIEVE(SEARCH_ SNL, LAST _FOUND); 
end RESTORE _CURRENT_ENTRY; 


procedure PRINT _SYMBOL_TABLE is 
-- post - Useful as a debugging tool, PRINT _SYMBOL_TABLE prints a dump of 
=< every symbol table entry, including attribute and location 
== information, to the standard output device. The current entry is 
ao undef ined. 
TEMP POINTER : LIST NODE POINTER; 
SEARCH_STACK : STK_OF_LISTS.STACK; 
TEMPLEPST : SYMBOL JEIST-EIST: 
SUCCESS : boolean; 
procedure PRINT _RECORD(SP : in SYM _TAB_ACCESS) is 
use TEXT_I0; 
begin 
new_line; 
for INDEX in 1..SP.NAME LENGTH loop 
put(SP.NAME(INDEX)); 
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end loop; 
set_col(30); 
put(SYMBOL_TAG'IMAGE(SP.TAG_TYPE)); 
set_col(60); 
put_line(natural' IMAGE(SP.LOCATION)); 
end PRINT_RECORD; 
begin 
STK_OF_LISTS.CREATE(SEARCH STACK, SUCCESS); 
if (not SUCCESS) then 
raise SYMBOL_TABLE_OVERFLOW; 
end if; 
if (not SYMBOL_LIST.EMPTY(SYM_TAB)) then 
SYMBOL_LIST.FIND_FIRST(SYM_TAB); 
TEMP_LIST := SYM_TAB; 
loop 
while (not SYMBOL_LIST.EMPTY(TEMP_LIST)) loop 
STK_OF_LISTS.PUSH( SEARCH STACK, TEMP_LIST); 
SYMBOL_LIST.RETRIEVE(TEMP_LIST, TEMP POINTER); 
TEMP_LIST := TEMP POINTER.SUB_LIST; 
if (not SYMBOL_LIST.EMPTY(TEMP_LIST)) then 
SYMBOL_LIST.FIND_FIRST( TEMP_LIST); 
end if; 
end loop; 
STK_OF_LISTS.POP(SEARCH STACK, TEMP_LIST); 
SYMBOL_LIST.RETRIEVE( TEMP_LIST, TEMP POINTER); 
PRINT _RECORD( TEMP_POINTER. SYMBOL ); 
if (not SYMBOL_LIST.LAST(TEMP_LIST)) then 
SYMBOL_LIST.FIND_NEXT(TEMP_LIST); 
else 
while (({not STK_OF_LISTS.EMPTY(SEARCH STACK)) and then 
(SYMBOL_LIST.LAST(TEMP_LIST))) loop 
STK_OF_LISTS.POP( SEARCH STACK, TEMP_LIST); 
SYMBOL_LIST.RETRIEVE(TEMP_LIST, TEMP_POINTER); 
PRINT RECORD( TEMP_POINTER.SYMBOL ) ; 
end loop; 
exit when ((STK_OF_LISTS.EMPTY(SEARCH STACK)) and then 
(SYMBOL_LIST.LAST( TEMP_LIST))); 
SYMBOL_LIST.FIND_NEXT(TEMP_LIST); 
end if; 
end loop; 
end if; 
LAST_FOUND := null; 
end PRINT SYMBOL TABLE; 


begin 


INITIALIZE SYM_ TAB; 
end SYMBOL_TABLE; 
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APPENDIX F 


“ADAFLOW” PROGRAM LISTING - CODE BLOCKER 


— H~FFSSFFSSSFSSESTSSSSTSSE SS SS SSESSSSSSSSS SSE SSSSSSES SSS ESTSE SEES SSS SSTE BES _ 


a=) TITEES ADAFLOW = 


-- MODULE NAME: PACKAGE CODE _BLOCKER a 
== FILE NAME: BLOCKER.ADS Sa 


-- DATE CREATED: 31 MAR 88 ee 
-- LAST MODIFIED: 28 APR 88 i 


-- AUTHOR(S): LT ALBERT J. GRECCO, USN -- 


-- DESCRIPTION: This package defines the interface to the =< 
=m CODE BLOCKER module. ae 


—-FSSSSESSSFSSESS SSS SSS SE SHSSE STE SSE SSFESSSSSESSESSESSSESSE SES SESE SESE SEVESGEFE_ 


with TOKEN SCANNER; -- only for visibility of type SOURCE_RECORD 
package CODE_BLOCKER is 


CODE _BLOCKER_UNDERFLOW : exception; 
CODE BLOCKER_OVERFLOW : exception; 
UNMATCHED_CODE_BLOCKS : exception; 


procedure ENTER_CODE_BLOCK(SOURCE : in TOKEN SCANNER. SOURCE _RECORD; 
LABEL : in string); 

-- post - A unique code block number, starting with the number 1 and 

ig Continuing sequentially, is generated and associated with 

== the new code block. The current code block number is the 

— new code block number. The statement count is set to zero. 


procedure INCREMENT STATEMENT COUNT; 

-- pre - A code block has been entered. 

-- post - Used to count the number of statements in a code 

= block. Initially zero, INCREMENT STATEMENT COUNT increases 

is the count of statements encountered in the current 

=> code block by 1. 

-- exceptions raised - UNMATCHED CODE_BLOCKS if a code block has not been 
aie entered. 


procedure DELETE CODE_BLOCK_ENTER; 
-- pre - A code block has been entered. 
-- post - The most recently entered code block is deleted and the state 
=r of the code blocker is restored to the state just prior to the 
erroneous code block entry. 
- exceptions raised - UNMATCHED CODE BLOCKS if a code block has not been 
mie entered. 
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function IS CODE _BLOCK_ENTERED return boolean; 
-- pre - If a code block has been entered and not yet exited, 
= IS _CODE_BLOCK_ENTERED returns true, else returns false. 


procedure EXIT CODE _BLOCK(SOURCE : in TOKEN SCANNER.SOURCE_RECORD) ; 

-- pre - A code block has been entered. 

-- post - The most recently entered code block is added to a list of 

a exited code blocks. The next most recently entered code block, 
= if it exists, becomes the current code block. 

-- exceptions raised - UNMATCHED CODE _BLOCKS if a code block has not been 
ig entered. 


procedure REACTIVATE CODE _BLOCK(CODE BLOCK_NUMBER : in positive); 

-- pre - The code block number exists in the list of exited code blocks. 
-- post - The code block is removed from the list of exited code blocks and 
oe made the current code block. 

-- exceptions raised - UNMATCHED CODE BLOCKS if a code block does not exist 
a in the list of exited code blocks with the named 

a CODE_BLOCK_ NUMBER. 

== CODE_BLOCKER _UNDERFLOW if the block list is clear. 


function CURRENT CODE _BLOCK_NUMBER return positive; 

-- pre - A code block has been entered and not yet exited. 

-- post - CURRENT_CODE_BLOCK_NUMBER returns the number of the current, 
aS code block that has most recently been entered. 

-- exceptions raised - CODE BLOCKER UNDERFLOW if the code blocker is 
aS not currently in a code block. 


function CURRENT STATEMENT COUNT return natural; 

-- pre - A code block has been entered. 

-- post - CURRENT STATEMENT COUNT returns the count of 

= — Statements encountered in the current code block. 

-- exceptions raised - UNMATCHED CODE BLOCKS if a code block has not been 
= entered. 


procedure CLEAR CODE BLOCKER; 

-- post - Clears the code blocker of all code blocks that have been entered 
ae and of all code blocks in the list of exited code blocks. The 

= current code block number is undefined. The next code block 

= number to be generated is 1. 


function IS _CODE_BLOCK_LIST_CLEAR return boolean; 
-- post - If no code blocks have been entered and exited then 
oo IS CODE _BLOCK_LIST_ CLEAR returns true, else returns false. 


function IS _ LAST CODE_BLOCK return boolean; 

-- pre - The code block list is not clear. 

-- post - If there are no other blocks of code in the list of code blocks, 
ae IS_LAST_CODE_ BLOCK returns true, else IS_LAST_CODE_BLOCK returns 
=o false. 

-- exceptions raised - CODE BLOCKER UNDERFLOW 1f the block list is clear. 
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procedure FIND FIRST CODE BLOCK; 

-- pre - The code block list is not clear and no code blocks have been 

i entered and not yet exited. 

-- post - Rewinds the code block list to the first block. The current block 
a in the code block list is the first block in the code block list. 
-- exceptions raised - CODE BLOCKER UNDERFLOW if the block list is clear. 

a UNMATCHED CODE BLOCKS if a block has been entered 

== and not yet exited. 


procedure FIND _NEXT_CODE_BLOCK; 

-- pre - The code block list is not at the last block and is not clear. 

ae No code blocks have been entered and not yet exited. 

-- post - The code blocker is advanced to the next block. The current block 
So in the code block list is the next block in the code block list. 
-- exceptions raised - CODE BLOCKER _UNDERFLOW if the block list is clear. 

me CODE _BLOCK_OVERFLOW if at the last block in the list. 
= UNMATCHED CODE BLOCKS if a block has been entered 

ae and not yet exited. 


function READ _CODE_BLOCK_NUMBER return positive; 

-- pre - The code block list is not clear. No code blocks have been 

=i entered and not yet exited. 

-- post - READ_CODE_BLOCK_NUMBER returns the code block number of the 

== current code block in the code block list. 

-- exceptions raised - CODE BLOCKER UNDERFLOW if the block list is clear. 
a UNMATCHED CODE_BLOCKS if a block has been entered 
ae and not yet exited. 


function READ_CODE_BLOCK_STATEMENT_COUNT return natural; 

-- pre - The code block list is not clear. No code blocks have been 

= entered and not yet exited. 

-- post - READ CODE _BLOCK_STATEMENT_COUNT returns the number of 

= statements recorded as encountered in the current code block 

ac in the code block list. 

-- exceptions raised - CODE BLOCKER _UNDERFLOW if the block list is clear. 
== UNMATCHED_CODE BLOCKS if a block has been entered 
= and not yet exited. 


function READ _CODE_BLOCK_START return TOKEN SCANNER.SOURCE_ RECORD; 

-- pre - The code block list is not clear. No code blocks have been 

oi entered and not yet exited. 

-- post - READ_CODE_BLOCK_START returns the record of origin of the 

a current code block in the code block list as it relates to the 
= source code. 

-- exceptions raised - CODE BLOCKER_UNDERFLOW if the block list is clear. 
+5 UNMATCHED CODE BLOCKS if a block has been entered 
as and not yet exited. 


function READ_CODE BLOCK STOP return TOKEN SCANNER.SOURCE RECORD: 


-- pre - The code block list is not clear. No code blocks have been 
i entered and not yet exited. 
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-- post - READ_CODE_BLOCK_STOP returns the record of completion of the 
== current code block in the code block list as it relates to the 
=< source code. 

-- exceptions raised - CODE BLOCKER UNDERFLOW if the code blocker is clear. 
== UNMATCHED CODE BLOCKS if a block has been entered 
= and not yet exited. 


function READ _CODE_BLOCK_LABEL return string; 

-- pre - The code block list is not clear. No code blocks have been 
oS entered and not yet exited. 

-- post - READ_CODE_BLOCK_LABEL returns the label entered when the 

== current code block in the code block list was entered. 

-- exceptions raised - CODE BLOCKER UNDERFLOW if the code blocker is clear. 
oS UNMATCHED CODE_BLOCKS if a block has been entered 
=- and not yet exited. 


end CODE BLOCKER; 
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aoe ae) OLN ADAFLOW =< 
~~ MODULE NAME: PACKAGE CODE_BLOCKER =o 
-- FILE NAME; BLOCKER.ADB = 


-- DATE CREATED: 31 MAR 88 a 
-- LAST MODIFIED: 28 APR 88 i 


-- AUTHOR(S): LT ALBERT J. GRECCO, USN =— 


-- DESCRIPTION: This package implements the interface to the == 
= CODE_BLOCKER module. -- 


——FFSTCTSSSCSSSSSSSTSSSSSFSSSSSSSSSSSST SSS SS SETS CSS SSS SESS SSS SES SsSESCSES Hess _ 


with ORDERED _GENERIC_LIST, 
GENERIC_STACK, 
UNCHECKED. DEALLOCATION, 
TOKEN SCANNER; -- only for visibility of type SOURCE_RECORD 


package body CODE_BLOCKER is 


type CODE_BLOCK_RECORD is 


record 
BLOCK_NUMBER > positive; 
STATEMENT COUNT : natural := 0; 
START : TOKEN_SCANNER. SOURCE_RECORD; 
STOP : TOKEN SCANNER. SOURCE RECORD; 
LABEL : string(1..TOKEN SCANNER.LINESIZE) := (others => ' 
LABEL_LENGTH >: Natural; 


end record; 
type CODE_BLOCK_ POINTER is access CODE BLOCK RECORD; 


NEXT BLOCK_NUMBER ; POSitive <:- =; 
CURRENT _BLOCK_NUMBER : positive; 


package BLOCK_LIST is new ORDERED GENERIC _LIST(CODE BLOCK POINTER); 
package BLOCK STACK is new GENERIC STACK(CODE_BLOCK POINTER); 
procedure FREE _CODE_BLOCK is new 


i 


UNCHECKED DEALLOCATION(CODE BLOCK RECORD, CODE BLOCK POINTER); 


BL 2" BLOCK LIST SEIS: 
BS : BLOCK_STACK.STACK; 


procedure INITIALIZE CODE BLOCKER is 
SUCCESS : boolean; 
begin 

BLOCK LIST CREATE(BE, SUCCESS); 
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if (not SUCCESS) then 

raise CODE BLOCKER OVERFLOW; 
end if; 
BLOCK_STACK.CREATE(BS, SUCCESS); 
if (not SUCCESS) then 

raise CODE BLOCKER OVERFLOW; 
end if; 
NEXT BLOCK NUMBER := 1; 

end INITIALIZE _CODE_BLOCKER; 


procedure ENTER _CODE_BLOCK(SOURCE : in TOKEN SCANNER. SOURCE_RECORD; 
LABEL : in string) is 
-- post - A unique code block number, starting with the number 1 and 
sig continuing sequentially, is generated and associated with 
ag the new code block. The current code block number is the 
== new code block number. 
TEMP POINTER : CODE_BLOCK_POINTER; 
begin 
TEMP_POINTER := new CODE _BLOCK_RECORD; 
TEMP_POINTER.BLOCK NUMBER := NEXT BLOCK_NUMBER; 
CURRENT BLOCK NUMBER := NEXT BLOCK NUMBER; 
NEXT _BLOCK_NUMBER := NEXT _BLOCK_NUMBER + 1; 
TEMP_POINTER.STATEMENT COUNT := 0; 
TEMP_POINTER.START := SOURCE; 
TEMP_POINTER.LABEL := (others => ' '); 
TEMP_POINTER.LABEL(1..LABEL'LAST) := LABEL; 
TEMP_POINTER.LABEL_LENGTH := LABEL'LENGTH; 
BLOCK_STACK.PUSH(BS, TEMP_POINTER) ; 
end ENTER _CODE_ BLOCK; 


it 


procedure INCREMENT STATEMENT COUNT is 
-- pre - A code block has been entered. 
-- post - Used to count the number of statements in a code 
a block. Initially zero, INCREMENT (STATEMENT COUNT increases 
as the count of statements encountered in the current 
= code block by 1. 
-- exceptions raised - UNMATCHED _CODE_BLOCKS if a code block has not been 
== entered. 
TEMP_POINTER : CODE BLOCK POINTER; 
begin 
if (BLOCK _STACK.EMPTY(BS)) then 
raise UNMATCHED CODE BLOCKS; 
else 
BLOCK_STACK.POP(BS, TEMP_POINTER); 
TEMP_POINTER.STATEMENT COUNT := 
natural'SUCC(TEMP_POINTER.STATEMENT COUNT); 
BLOCK _STACK.PUSH(BS, TEMP_PDINTER); 
end if; 
end INCREMENT STATEMENT CDUNT; 
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procedure DELETE CODE BLOCK_ENTER is 
-- pre - A code block has been entered. 
-- post - The most recently entered code block is deleted and the state 
5 of the code blocker is restored to the state just prior to the 
== erroneous code block entry. 
-- exceptions raised - UNMATCHED_CODE_BLOCKS if a code block has not been 
es entered. 
TEMP_POINTER : CODE_BLOCK_ POINTER; 
begin 
if (BLOCK_STACK.EMPTY(BS)) then 
raise UNMATCHED CODE BLOCKS; 
else 
BLOCK_STACK.POP(BS, TEMP_POINTER); 
FREE CODE _BLOCK(TEMP_POINTER) ; 
NEXT _BLOCK_NUMBER := NEXT _BLOCK_NUMBER - 1; 
if (mot BLOCK_STACK.EMPTY(BS)) then 
BLOCK_STACK.TOP(BS, TEMP_POINTER); 
CURRENT _BLOCK_NUMBER := TEMP_POINTER.BLOCK_NUMBER; 
end if; 
end if; 
end DELETE CODE BLOCK_ENTER; 


function IS CODE BLOCK_ENTERED return boolean is 
-- pre - If a code block has been entered and not yet exited, 
a IS_CODE_BLOCK_ENTERED returns true, else returns false. 
begin 
return (not BLOCK_STACK.EMPTY(BS)); 
end IS CODE _BLOCK_ENTERED; 


procedure EXIT_CODE_BLOCK(SOURCE : in TOKEN _SCANNER.SOURCE RECORD) is 
-- pre - A code block has been entered. 
-- post - The most recently entered code block is added to a list of 
a= exited code blocks. The next most recently entered code block, 
=3 if it exists, becomes the current code block. 
-- exceptions raised - UNMATCHED _CODE_ BLOCKS if a code block has not been 
== entered. 
TEMP_POINTER : CODE_BLOCK_POINTER; 
begin 
if (BLOCK_STACK.EMPTY(BS)) then 
raise UNMATCHED CODE BLOCKS; 
else 
BLOCK_STACK.POP(BS, TEMP POINTER); 
TEMP_POINTER.STOP := SOURCE; 
BLOCK_LIST.INSERT(BL, TEMP _POINTER, TEMP_POINTER.BLOCK NUMBER) ; 
if (not BLOCK _STACK.EMPTY(BS)) then 
BLOCK _STACK.TOP(BS, TEMP POINTER); 
CURRENT BLOCK NUMBER := TEMP_POINTER.BLOCK_NUMBER; 
end if; 
end if; 
end EXIT CODE BLOCK; 
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procedure REACTIVATE CODE_BLOCK(CODE_BLOCK_NUMBER : in positive) is 
-- pre - The code block number exists in the list of exited code blocks. 
-- post - The code block is removed from the list of exited code blocks and 
= made the current code block. 
-- exceptions raised - UNMATCHED CODE BLOCKS if a code block does not exist 
oe in the list of exited code blocks with the named 
<- CODE _BLOCK_ NUMBER. 
as CODE BLOCKER _UNDERFLOW if the block list is clear. 
TEMP POINTER : CODE_BLOCK_POINTER; 
begin 
if (BLOCK_LIST.EMPTY(BL)) then 
raise CODE _BLOCKER_UNDERFLOW; 
else 
BLOCK_LIST.FINO _FIRST(BL); 
BLOCK_LIST.RETRIEVE(BL, TEMP POINTER); 
while (TEMP_POINTER.BLOCK_ NUMBER /= CODE _BLOCK_NUMBER) loop 
if (BLOCK_LIST.LAST(BL)) then 
raise UNMATCHED CODE BLOCKS; 
else 
BLOCK_LIST.FIND_NEXT(BL); 
BLOCK_LIST.RETRIEVE(BL, TEMP _POINTER); 
end if; 
end loop; 
BLOCK_LIST.DOELETE(BL); 
BLOCK_STACK.PUSH(BS, TEMP_POINTER); 
CURRENT _BLOCK_NUMBER := CODE _BLOCK_NUMBER; 
end if; 
end REACTIVATE CODE BLOCK; 


function CURRENT _CODE_BLOCK_NUMBER return positive is 
-- pre - A code block has been entered and not yet exited. 
-- post - CURRENT CODE _BLOCK_NUMBER returns the number of the current, 
= code block that has most recently been entered. 
-- exceptions raised - CODE_BLOCKER_UNDERFLOW if the code blocker is 
aS not currently in a code block. 
begin 
if (BLOCK_STACK.EMPTY(BS)) then 
raise CODE_BLOCKER_UNDERFLOW; 
else 
return (CURRENT _BLOCK_NUMBER); 
end if; 
end CURRENT CODE _BLOCK_NUMBER; 


function CURRENT STATEMENT COUNT return natural is 

-- pre - A code block has been entered. 

-- post - CURRENT_STATEMENT_COUNT returns the count of 

ie statements encountered in the current code block. 

-- exceptions raised - UNMATCHED CODE BLOCKS if a code block has not been 
=> entered. 

TEMP POINTER : CODE_BLOCK_ POINTER; 

begin 
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if (BLOCK_STACK.EMPTY(BS)) then 
raise UNMATCHED _CODE_BLOCKS; 
else 
BLOCK _STACK.TOP(BS, TEMP _POINTER); 
return (TEMP_POINTER.STATEMENT COUNT); 
end if; 
end CURRENT _STATEMENT_COUNT; 


procedure CLEAR_CODE_BLOCKER is 
-- post - Clears the code blocker of all code blocks that have been entered 
ae and of all code blocks in the list of exited code blocks. The 
=< current code block number is undefined. The next code block 
= number to be generated is 1. 
TEMP_POINTER : CODE_BLOCK_POINTER; 
begin 
while (not BLOCK_LIST.EMPTY(BL)) loop 
BLOCK_LIST.RETRIEVE(BL, TEMP_POINTER); 
FREE CODE _BLOCK( TEMP POINTER); 
BLOCK_LIST.DELETE(BL); 
end loop; 
while (not BLOCK_STACK.EMPTY(BS)) loop 
BLOCK_STACK.POP(BS, TEMP_POINTER); 
FREE_CODE_BLOCK({ TEMP_POINTER); 
end loop; 
NEXT_BLOCK_NUMBER := 1; 
end CLEAR_CODE_BLOCKER; 


function IS _CODE_BLOCK_LIST_CLEAR return boolean is 
-- post - If no code blocks have been both entered and exited then 
a IS CODE_BLOCK_LIST_CLEAR returns true, else returns false. 
begin 

return (BLOCK_LIST.EMPTY(BL)); 
end IS CODE _BLOCK_LIST_CLEAR; 


function IS_LAST_CODE_BLOCK return boolean is 
-- pre - The code block list is not clear. 
-- post - If there are no other blocks of code in the list of code blocks, 
oe IS_LAST_CODE_BLOCK returns true, else IS_LAST_CODE_BLOCK returns 
-- false. 
-- exceptions raised - CODE_BLOCKER _UNDERFLOW if the block list is clear. 
begin 
if (BLOCK_LIST.EMPTY(BL)) then 
raise CODE BLOCKER _UNDERFLOW; 
else 
return (BLOCK LIST.LAST(BL)); 
end if; 
end IS _ LAST CODE BLOCK; 


procedure FIND FIRST CODE BLOCK is 


- pre - The code block list is not clear and no code blocks have been 
entered and not yet exited. 
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-- post - Rewinds the code block list to the first block. Ihe current block 
ate in the code block list is the first block in the code block list. 
-- exceptions raised - CODE_BLOCKER_UNDERFLOW if the block list is clear. 
a UNMATCHED CODE BLOCKS if a block has been entered 
= and not yet exited. 
begin 
if (BLOCK_LIST.EMPTY(BL)) then 
raise CODE BLOCKER UNDERFLOw; 
elsif (not BLOCK_STACK.EMPTY(BS)) then 
raise UNMATCHED CODE_BLOCKS; 
else 
BLOCK _LIST.FIND_FIRST(BL); 
end if; 
end FIND_FIRST_CODE_B8LOCK; 


procedure FIND_NEXT_CODE_BLOCK is 
-- pre - The code block list is not at the last block and is not clear. 
id No code blocks have been entered and not yet exited. 
-- post - The code blocker is advanced to the next block. The current block 
aia in the code block list is the next block in the code block list. 
-- exceptions raised - CODE_BLOCKER_UNDERFLOW if the block list is clear. 
i CODE_BLOCK_OVERFLOW if at the last block in the list. 
== UNMATCHED_CODE_BLOCKS if a block has been entered 
=< and not yet exited. 
begin 
if (BLOCK_LIST.EMPTY(BL)) then 
raise CODE BLOCKER_UNDERFLOW; 
elsif (BLOCK _LIST.LAST(BL)) then 
raise CODE BLOCKER OVERFLOW; 
elsif (not BLOCK _STACK.EMPTY(BS)) then 
raise UNMATCHED CODE BLOCKS; 
else 
BLOCK_LIST.FIND_NEXT(BL); 
end if; 
end FIND _NEXT_CODE_ BLOCK; 


function READ CODE BLOCK _NUMBER return positive is 
-- pre - The code block list is not clear. No code blocks have been 
ac entered and not yet exited. 
-- post - READ_CODE _BLOCK_NUMBER returns the code block number of the 
= current code block in the code block list. 
-- exceptions raised - CODE _BLOCKER_UNDERFLOW if the block list is clear. 
se UNMATCHED CODE BLOCKS if a block has been entered 
== and not yet exited. 
TEMP POINTER : CODE_BLOCK_POINTER; 
begin 
if (BLOCK_LIST.EMPTY(BL)) then 
raise CODE BLOCKER UNDERFLOW; 
elsif (mot BLOCK STACK.EMPTY(BS)) then 
raise UNMATCHED CODE BLOCKS; 
else 
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BLOCK_LIST.RETRIEVE(BL, TEMP_POINTER); 
return (TEMP_POINTER.BLOCK_NUMBER) ; 
end if; 
end READ_CODE_BLOCK_NUMBER; 


function READ _CODE_BLOCK_STATEMENT COUNT return natural is 
-- pre - The code block 11st is not clear. No code blocks have been 
=i entered and not yet exited. 
-- post - READ _CODE_BLOCK_STATEMENT COUNT returns the number of 
=> Statements recorded as encountered in the current code block 
ee in the code block list. 
-- exceptions raised - CODE_BLOCKER_UNDERFLOW if the block list is clear. 
= UNMATCHED_CODE_BLOCKS if a block has been entered 
ne and not yet exited. 
TEMP_POINTER : CODE_BLOCK_POINTER; 
begin 
if (BLOCK_LIST.EMPTY(BL)) then 
raise CODE BLOCKER_UNDERFLOW; 
elsif (not BLOCK_STACK.EMPTY(BS)) then 
raise UNMATCHED CODE_BLOCKS; 
else 
BLOCK_LIST.RETRIEVE(BL, TEMP_POINTER); 
return (TEMP_POINTER.STATEMENT COUNT) ; 
end if; 
end READ_CODE_BLOCK_STATEMENT_COUNT; 


function READ _CODE_BLOCK_START return TOKEN _SCANNER.SOURCE_RECORD is 
-- pre - The code block list is not clear. No code blocks have been 
ae entered and not yet exited. 
-- post - READ_CODE_BLOCK_START returns the record of origin of the 
== current code block in the code block list as it relates to the 
Si source code. 
-- exceptions raised - CODE _BLOCKER_UNDERFLOW if the block list is clear. 
i UNMATCHED CODE BLOCKS if a block has been entered 
== and not yet exited. 
TEMP POINTER : CODE BLOCK POINTER; 
begin 
if (BLOCK LIST.EMPTY(BL)) then 
raise CODE BLOCKER UNDERF LOW; 
elsif (not BLOCK_STACK.EMPTY(BS)) then 
raise UNMATCHED CODE BLOCKS; 
else 
BLOCK _LIST.RETRIEVE(BL, TEMP_POINTER); 
return (TEMP_POINTER.START); 
end if; 
end READ _CODE_BLOCK_ START; 


tunction READ CODE BLOCK STOP return TOKEN SCANNER.SOURCE RECORD jis 
-- pre - The code block list is not clear. No code blocks have been 
aie entered and not yet exited. 

post - READ _CODE_BLOCK STOP returns the record of completion of the 
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== current code block in the code block list as tt relates to the 
a source code. 
-- exceptions raised - CODE BLOCKER UNDERFLOW if the code blocker is clear. 
= UNMATCHED _CODE_BLOCKS if a block has been entered 
— and not yet exited. 
TEMP POINTER : CODE_BLOCK POINTER; 
begin 
if (BLOCK_LIST.EMPTY(BL)) then 
raise CODE BLOCKER UNDERFLOW; 
elsif (not BLOCK_STACK.EMPTY(BS)) then 
raise UNMATCHED _CODE_ BLOCKS; 
else 
BLOCK_LIST.RETRIEVE(BL, TEMP _POINTER); 
return (TEMP_POINTER.STOP) ; 
end if; 
end READ _CODE_BLOCK_STOP; 


function READ CODE _BLOCK_LABEL return string is 
-- pre - The code block list is not clear. No code blocks have been 
a entered and not yet exited. 
-- post - READ_CODE_BLOCK_LABEL returns the label entered when the 
= current code block in the code block list was entered. 
-- exceptions raised - CODE BLOCKER _UNDERFLOW if the code blocker is clear. 
og UNMATCHED CODE BLOCKS if a block has been entered 
se and not yet exited. 
TEMP_POINTER : CODE BLOCK POINTER; 
begin 
if (BLOCK_LIST.EMPTY(BL)) then 
raise CODE BLOCKER _UNDERFLOW; 
elsif (not BLOCK_STACK.EMPTY(BS)) then 
raise UNMATCHED CODE BLOCKS; 
else 
BLOCK_LIST.RETRIEVE(BL, TEMP POINTER); 
return (TEMP_POINTER.LABEL(1..TEMP_POINTER.LABEL_LENGTH)); 
end if; 
end READ _CODE_BLOCK_LABEL; 


begin 


INITIALIZE_CODE_BLOCKER; 
end CODE_BLOCKER; 
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APPENDIX G 
“ADAFLOW” PROGRAM LISTING - TOKEN MATCHER 
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=o mele 1 (1 8 ADAFLOW = 


-- MODULE NAME: PACKAGE TOKEN _MATCHER = 
-- FILE NAME: MATCH. ADS == 


-- DATE CREATED: 18 FEB 88 a 
-- LAST MODIFIED: 28 APR 88 ce 


-- AUTHOR(S): LT ALBERT J. GRECCO, USN -- 


-- DESCRIPTION: This package defines the interface to the = 
== module that identifies each individual oe 
=, token and manages the TOKEN SCANNER. The = 
a TOKEN_MATCHER is the sole manager of the == 
— TOKEN_SCANNER interface and all access to the -- 
== TOKEN SCANNER interface is through TOKEN_ a 
-~ MATCHER. This restriction does not apply to ie 
== types specified in the TOKEN SCANNER -- 
a= interface. Types specified in the TOKEN_ = 
as SCANNER interface are available for global use.-- 


—-SFSFSSSFSSFSSSSSSSSSESSSSSSSSSSSSSSSSSSSSFSSSSSSSFSSSSRSSVSSFSSVSIF*VBB# __ 


with TOKEN SCANNER; 
package TOKEN _MATCHER is 
-- The following token codes define the terminals of the ADA language. 


-- basic tokens 


TOKEN_IDENTIFIER : constant integer := 1; 
TOKEN NUMERIC LITERAL : constant integer := 2; 
TOKEN CHARACTER LITERAL : constant integer := 3; 
TOKEN STRING LITERAL >: constant integer := 4; 
-- reserved word tokens 
TOKEN_END : constant integer := 5; 
TOKEN BEGIN : constant integer := 6; 
TOKEN_IF : constant integer := 7; 
TOKEN_THEN : Constant integer := 8; 
TOKEN ELSIF : constant integer := 9; 
TOKEN ELSE : constant integer := 10; 
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TOKEN WHILE 
TOKEN _LOOP 
TOKEN CASE 
TOKEN WHEN 
TOKEN DECLARE 
TOKEN FOR 
TOKEN_OTHERS 
TOKEN RETURN 
TOKEN_EXIT 
TOKEN_PROCEDURE 
TOKEN_FUNCTION 
TOKEN WITH 
TOKEN_USE 
TOKEN_PACKAGE 
TOKEN _BODY 
TOKEN_RANGE 
TOKEN_IN 

TOKEN OUT 
TOKEN_SUBTYPE 
TOKEN_TYPE 
TOKEN_IS 
TOKEN_NULL 
TOKEN_ACCESS 
TOKEN ARRAY 
TOKEN DIGITS 
TOKEN_DELTA 
TOKEN _RECORD_STRUCTURE 
TOKEN_CONSTANT 
TOKEN_NEW 
TOKEN EXCEPTION 
TOKEN_RENAMES 
TOKEN _PRIVATE 
TOKEN LIMITED 
TOKEN_TASK 
TOKEN_ENTRY 
TOKEN _ACCEPT 
TOKEN_DELAY 
TOKEN _SELECT 
TOKEN TERMINATE 
TOKEN_ABORT 
TOKEN_SEPARATE 
TOKEN_RAISE 
TOKEN_GENERIC 
TOKEN_AT 
TOKEN_REVERSE 
TOKEN_DO 

TOKEN GOTO 
TOKEN_OF 
TOKEN_ALL 
TOKEN PRAGMA 
TOKEN AND 


+ Constant 


constant 
constant 


: constant 
: constant 


constant 
constant 


; constant 
: constant 


constant 
constant 
constant 


: constant 
> constant 


constant 
constant 


: constant 


constant 
constant 
constant 


> constant 


constant 


> Constant 


constant 
constant 


: constant 


constant 
constant 


> constant 


constant 


: constant 
> constant 
: constant 
: constant 


constant 
constant 


: constant 


constant 
constant 


> constant 


constant 


> constant 


constant 


: constant 
: constant 
> constant 
: constant 


constant 
constant 
constant 
constant 


integer : 
integer : 
integer : 
integer : 
integer : 
integer : 
integer : 
integer : 
integer : 
integer : 
integer : 
integer : 
integer : 
integer : 
integer : 
integer : 
integer : 
integer : 
integer : 
mteger = 
integer : 
integer : 
integer : 
integer : 
integer : 
integer : 
integer : 
integer : 
integer : 
integer : 
integer : 
integer : 
integer : 
integer : 
integer : 
integer : 
integer : 
integer : 
integer : 
integer : 
integer : 
integer : 
integer : 
integer : 
integer ; 
integer : 
integer : 
integer : 
integer : 
integer : 


integer 
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eles 
ee 
13: 
14; 
15; 
16° 
lees 
18; 
19; 
20; 
21% 
ee 
Za 
24; 
255 
26; 
Zl; 
28; 
29; 
30; 
Sak 
323 
a3; 
34; 
358 
36; 
Sie 
38; 
39; 
40; 
41: 
42; 
43; 
44; 
45; 
46; 
47; 
48; 
49; 
50; 
5ylle 
S25 
J) 
54; 
Sie 
56; 
ove 
oa: 
59; 
60; 
61; 


TOKEN _OR > constant integer := 62; 
TOKEN NOT : constant integer := 63; 
TOKEN _XOR ; constant integer := 64; 
TOKEN _MOD constant integer := 65; 
TOKEN_REM > constant integer := 66; 
TOKEN_ABSOLUTE : constant integer := 67; 
delimiter tokens 

TOKEN_ASTERISK > constant integer := 68; 
TOKEN SLASH : constant integer := 69; 
TOKEN EXPONENT : constant integer := 70; 
TOKEN PLUS : constant integer := 71; 
TOKEN_MINUS : constant integer := 72; 
TOKEN_AMPERSAND >: constant integer 73: 
TOKEN_EQUALS : constant integer := 74; 
TOKEN _NOT_EQUALS >: constant integer := 75; 
TOKEN _LESS_THAN : constant integer := 76; 
TOKEN_LESS_THAN_EQUALS : constant integer := 77; 
TOKEN _GREATER_THAN > Constant integer 78; 
TOKEN _GREATER_THAN_EQUALS : constant integer := 79; 
TOKEN_ASSIGNMENT constant integer := 80; 
TOKEN_SEMICOLON > constant integer := 81; 
TOKEN_PERIOD > constant integer := 82; 
TOKEN_LEFT_PAREN > constant integer := 83; 
TOKEN_RIGHT_PAREN : constant integer := 84; 
TOKEN _COLON ; constant integer := 85; 
TOKEN_COMMA : constant integer := 86; 
TOKEN_APOSTROPHE : constant integer := 87; 
TOKEN RANGE _DOTS : constant integer := 88; 
TOKEN ARROW > constant integer := 89; 
TOKEN BAR : Constant integer := 90; 
TOKEN BRACKETS > constant integer := 91; 
TOKEN LEFT BRACKET : Constant integer := 92; 
TOKEN_RIGHT_BRACKET : constant integer := 93; 
procedure SET_UP_TOKEN MATCHER(FILE_NAME : string); 
-- pre - must be called before any of the defined interfaces in 
he TOKEN MATCHER are invoked. Any previously set up FILE _NAME 
ka must be released by RELEASE TOKEN SCANNER. 
-- post - the TOKEN MATCHER interfaces are defined. 
procedure RELEASE _ TOKEN MATCHER; 

-- pre - TOKEN _MATCHER has been set up. 

-- post - all TOKEN MATCHER interfaces are undefined with the 


a exception of SET_UP_TOKEN MATCHER. 
aS TOKEN MATCHER may be set up for another FILE NAME. 
= TOKEN MATCHER must be released prior to main program 


The 
i. termination. 
function MATCH( TOKEN CODE in positive) return boolean; 


-- pre - TOKEN MATCHER has been set up. 
-- post - if the current token under the read head of the TOKEN SCANNER 
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-- matches the TOKEN COOE then MATCH is TRUE and the read head of 
= the TOKEN SCANNER is advanced one token. Else MATCH is FALSE 
== and the read head of the TOKEN SCANNER does not advance. 


procedure MATCHEO TOKEN( TOKEN : out TOKEN SCANNER. TOKEN _RECORD_TYPE); 

-- pre - TOKEN _MATCHER has been set up and at least one call to the 

-- function MATCH has returned TRUE. 

-- post - TOKEN contains the token that caused the last call to MATCH 

Se to be TRUE. NOTE - All identifiers are converted to upper 

== case by the token matcher and all reserved words are converted 
== to lower case by the token matcher regardless of original format 
== in the source code. All other token types are left in original 
ae source code format. 


procedure CURRENT _TOKEN( TOKEN : out TOKEN _SCANNER.TOKEN_RECORO_ TYPE); 
-- pre - TOKEN_MATCHER has been set up. 

-- post - TOKEN contains the token that is under the TOKEN _SCANNER's 
a= read head. 


procedure NEXT _TOKEN(TOKEN : out TOKEN SCANNER. TOKEN RECORO_TYPE); 
-- pre - TOKEN_MATCHER has been set up. 

-- post - TOKEN contains the token that is next to be read by the 
oo TOKEN_SCANNERS read head. 


function LINES CHECKED return positive; 

-- pre - TOKEN_MATCHER has been set up. 

-- post - returns the number of lines of code that have been checked 
ae by the TOKEN MATCHER. 


function VALIO COMMENTS return natural; 

-- pre - TOKEN MATCHER has been set up. 

-- post - returns the number of “meaningful” comments seen by the 

== TOKEN MATCHER. A “meaningful” comment is defined as a comment 
== that contains at least one letter or digit. 


end TOKEN MATCHER; 
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== OFDTEE: ADAFLOW == 
-- MODULE NAME: PACKAGE TOKEN_MATCHER i 
-- FILE NAME: MATCH .ADB oa 


-- DATE CREATED: 18 FEB 88 -- 
-- LAST MODIFIED: 28 APR 88 aa 


-- AUTHOR(S): LT ALBERT J. GRECCO, USN a 


-- DESCRIPTION: This package implements the interface to the == 
=< module that identifies each individual =< 
== token and manages the TOKEN SCANNER. The == 
= TOKEN _MATCHER is the sole manager of the ae 
== TOKEN SCANNER interface and all access to the -- 
= TOKEN SCANNER interface is through TOKEN_ is 
-- MATCHER. This restriction does not apply to a 
a types specified in the TOKEN SCANNER = 
== interface. Types specified in the TOKEN_ == 
ao SCANNER interface are available for global use.-- 


——SSSSSTSTSSSSSHSSSSSSSSSSSSSSVSSTSSSSSSSSSSSLCSSSSSSS VS STSSSSssHsse ss. 


with TOKEN SCANNER, TEXT_IO; 
package body TOKEN MATCHER is 


SOURCE _FILE : TEXT_IO.file type; 
HOLD_TOKEN : TOKEN SCANNER. TOKEN RECORD TYPE; 


procedure SET_UP_TOKEN MATCHER(FILE_NAME : string) is 
-- pre - must be called before any of the defined interfaces in 
-- TOKEN _MATCHER are invoked. Any previously set up FILE NAME 
Sar must be released by RELEASE _TOKEN_ SCANNER. 
-- post - the TOKEN _MATCHER interfaces are defined. 
begin 
TEXT_I0.open(SOURCE_FILE, TEXT_I0.in_file, FILE_NAME, ""); 
TEXT I0.reset( SOURCE FILE); 
TOKEN _SCANNER.SET_UP_TOKEN SCANNER( SOURCE FILE); 
end SET_UP_TOKEN_MATCHER; 


procedure RELEASE TOKEN MATCHER is 

-- pre - TOKEN MATCHER has been set up. 

-- post - all TOKEN _MATCHER interfaces are undefined with the 

<< exception of SET UP_TOKEN MATCHER. 

== TOKEN MATCHER may be set up for another FILE_NAME. the 
-- TOKEN MATCHER must be released prior to main program 

ae termination. 
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TOKEN SCANNER.RELEASE_ TOKEN SCANNER(SOURCE_FILE); 
end RELEASE_TOKEN MATCHER; 


function MATCH( TOKEN CODE : in positive) return boolean is 
-- pre - TOKEN _MATCHER has been set up. 
-- post - if the current token under the read head of the TOKEN SCANNER 
== matches the TOKEN _CODE then MATCH is true and the read head of 
ze the TOKEN SCANNER is advanced one token. Else MATCH is false 
a and the read head of the TOKEN_SCANNER does not advance. 
use TOKEN SCANNER; 
subtype BASIC_TOKENS is 

positive range TOKEN IDENTIFIER. . TOKEN _STRING_LITERAL; 
subtype RESERVED_TOKENS is 

positive range TOKEN _END..TOKEN ABSOLUTE; 
subtype DELIMITER TOKENS is 

positive range TOKEN _ASTERISK..TOKEN_ RIGHT BRACKET; 


CURRENT_TOKEN : TOKEN_SCANNER. TOKEN _RECORD_TYPE; 
TEST TOKEN : TOKEN SCANNER. TOKEN _RECORD_TYPE; 
IS_ SAME : boolean := FALSE; 


function ASSIGN(TEST_STRING : in string) return 
TOKEN_SCANNER. TOKEN _RECORD_TYPE is 
TEMP_TOKEN : TOKEN SCANNER.TOKEN_RECORD_TYPE; 
begin 
TEMP_TOKEN.LEXEME SIZE TEST_STRING'LENGTH; 
TEMP_TOKEN.LEXEME (others => ' '); 
TEMP_TOKEN.LEXEME(1..TEST_STRING'LAST) := TEST_STRING; 
TEMP_TOKEN.SOURCE := CURRENT TOKEN. SOURCE; 
if (TOKEN CODE in RESERVED_TOKENS) then 
TEMP_TOKEN.TOKEN_TYPE := TOKEN _SCANNER.RESERVED WORD; 
elsif (TOKEN CODE in DELIMITER TOKENS) then 
TEMP_TOKEN.TOKEN_TYPE := TOKEN SCANNER.DELIMITER; 
end if; 
return TEMP_TOKEN; 
end ASSIGN; 


procedure CONVERT UPPER CASE( TOKEN : 
in out TOKEN SCANNER.TOKEN RECORD _TYPE) is 
Subtype UPPER CASE LETTER is character range 'A‘..'Z'; 
subtype LOWER CASE LETTER is character range ‘a‘..'z'; 
begin 
for LEXEME INDEX in 1..TOKEN.LEXEME_ SIZE loop 
if TOKEN.LEXEME(LEXEME INDEX) in LOWER _CASE_LETTER then 
TOKEN.LEXEME(LEXEME INDEX) := 
UPPER_CASE_LETTER'VAL(LOWER CASE _LETTER' POS( 
TOKEN.LEXEME(LEXEME INDEX)) - 32); 
end if; 
end loop; 
end CONVERT_UPPER_ CASE; 
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procedure CONVERT LOWER _CASE(TOKEN : 
in out TOKEN _SCANNER.TOKEN_RECORD_TYPE) is 
subtype UPPER _CASE_LETTER is character range 'A'..'Z'; 
subtype LOWER CASE LETTER is character range ‘'a'..'z'; 
begin 
for LEXEME INDEX in 1..TOKEN.LEXEME SIZE loop 
if TOKEN.LEXEME(LEXEME INDEX) in UPPER_CASE_LETTER then 
TOKEN.LEXEME(LEXEME_ INDEX) := 
LOWER_CASE_LETTER'VAL(UPPER_CASE_LETTER' POS( 
TOKEN. LEXEME(LEXEME_INDEX)) + 32); 
end if; 
end loop; 
end CONVERT_LOWER_CASE; 
begin 
TOKEN _SCANNER.LOOK_TOKEN(SOURCE_FILE, CURRENT _TOKEN); 
if (TOKEN CODE in BASIC_TOKENS) then 
case TOKEN CODE is 
when TOKEN_IDENTIFIER => 
IS_SAME := (CURRENT_TOKEN.TOKEN_ TYPE 
if (I1S_SAME) then 
CONVERT _UPPER_CASE(CURRENT_TOKEN); 
end if; 
when TOKEN _NUMERIC_LITERAL => 
IS_SAME := (CURRENT TOKEN. TOKEN_TYPE 
when TOKEN _CHARACTER_LITERAL => 
IS_SAME := (CURRENT TOKEN. TOKEN_TYPE 
when TOKEN STRING LITERAL => 
IS_ SAME := (CURRENT _TOKEN.TOKEN_TYPE 
when others => null; 


TOKEN_SCANNER. IDENTIFIER); 


TOKEN _SCANNER.NUMERIC_LIT); 


TOKEN _SCANNER.CHARACTER_LIT); 


TOKEN_SCANNER.STRING LIT); 


end case; 
else 
CONVERT_LOWER_CASE(CURRENT_TOKEN); 
case TOKEN CODE is 
when TOKEN _END => 
TEST_TOKEN := ASSIGN("end"); 
when TOKEN BEGIN => 
TEST _TOKEN ASSIGN("begin"); 
when TOKEN_IF => 
TEST_TOKEN := ASSIGN("if"); 
when TOKEN _THEN => 
TEST TOKEN := ASSIGN(“then"); 
when TOKEN ELSIF => 
TEST TOKEN := ASSIGN(“elisif"); 
when TOKEN ELSE => 
TEST_TOKEN := ASSIGN("else"); 
when TOKEN WHILE => 
TEST _ TOKEN := ASSIGN("while"); 
when TOKEN LOOP => 
TEST TOKEN := ASSIGN("loop"); 
when TOKEN CASE => 
TEST TOKEN := ASSIGN("Ccase"); 


ul 
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when TOKEN WHEN => 

TEST_TOKEN := ASSIGN(“when"); 
when TOKEN DECLARE => 

TEST_TOKEN := ASSIGN("declare"); 
when TOKEN FOR => 

TEST_TOKEN := ASSIGN("for"); 
when TOKEN OTHERS => 

TEST_TOKEN := ASSIGN("others"); 
when TOKEN RETURN => 

TEST_TOKEN := ASSIGN("return”); 
when TOKEN EXIT => 

TEST_TOKEN := ASSIGN("exit"); 
when TOKEN PROCEDURE => 

TEST_TOKEN := ASSIGN( "procedure" ); 
when TOKEN FUNCTION => 

TEST_TOKEN := ASSIGN( "function" ); 
when TOKEN WITH => 

TEST_TOKEN := ASSIGN("with"); 
when TOKEN_USE => 

TEST_TOKEN := ASSIGN("use"); 
when TOKEN PACKAGE => 

TEST_TOKEN := ASSIGN("package"); 
when TOKEN BODY => 

TEST_TOKEN := ASSIGN("body”); 
when TOKEN_RANGE => 


TEST_TOKEN := ASSIGN("range”"); 
when TOKEN_IN => 
TEST_TOKEN := ASSIGN("in"); 


when TOKEN OUT => 

TEST_TOKEN := ASSIGN("out"); 
when TOKEN SUBTYPE => 

TEST_TOKEN := ASSIGN( "subtype" ); 
when TOKEN _TYPE => 

TEST_TOKEN := ASSIGN("type"); 
when TOKEN_IS => 

TEST_TOKEN := ASSIGN("is"); 
when TOKEN NULL => 

TEST_TOKEN := ASSIGN("nuli"); 
when TOKEN ACCESS => 

TEST_TOKEN := ASSIGN("access"); 
when TOKEN_ARRAY => 

TEST_TOKEN := ASSIGN("array"); 
when TOKEN DIGITS => 

TEST TOKEN := ASSIGN("digits"); 
when TOKEN DELTA => 

TEST TOKEN := ASSIGN("delta”); 
when TOKEN _RECORD_STRUCTURE => 

TEST TOKEN := ASSIGN("record”); 
when TOKEN CONSTANT => 

TEST TOKEN := ASSIGN( "constant" ); 
when TOKEN NEW => 
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TEST_TOKEN := ASSIGN("new”); 
when TOKEN EXCEPTION => 

TEST_TOKEN := ASSIGN("exception"); 
when TOKEN RENAMES => 

TEST TOKEN := ASSIGN( "renames" ); 
when TOKEN PRIVATE => 

TEST TOKEN := ASSIGN("private"); 
when TOKEN LIMITED => 

TEST_TOKEN := ASSIGN("1imited"); 
when TOKEN_TASK => 

TEST TOKEN := ASSIGN("task"); 
when TOKEN ENTRY => 

TEST_TOKEN := ASSIGN("entry”); 
when TOKEN_ACCEPT => 

TEST_TOKEN := ASSIGN("accept"); 
when TOKEN_DELAY => 

TEST_TOKEN := ASSIGN("delay”); 
when TOKEN SELECT => 

TEST_TOKEN := ASSIGN("select"); 
when TOKEN_TERMINATE => 

TEST_TOKEN := ASSIGN("terminate”) ; 
when TOKEN_ABORT => 

TEST TOKEN := ASSIGN("abort"); 
when TOKEN_SEPARATE => 

TEST_TOKEN := ASSIGN( "separate" ); 
when TOKEN RAISE => 

TEST_TOKEN := ASSIGN("raise"); 
when TOKEN GENERIC => 


TEST_TOKEN := ASSIGN("generic"); 
when TOKEN AT => 
TEST TOKEN := ASSIGN("at"); 


when TOKEN REVERSE => 

TEST_TOKEN := ASSIGN( "reverse" ); 
when TOKEN DO => 

TEST_TOKEN := ASSIGN("do"); 
when TOKEN GOTO => 

TEST_TOKEN := ASSIGN("goto"); 
when TOKEN_OF => 

TEST_TOKEN := ASSIGN("of"); 
when TOKEN_ALL => 

TEST_TOKEN := ASSIGN("al1"); 
when TOKEN PRAGMA => 

TEST_TOKEN := ASSIGN( "pragma" ); 
when TOKEN_AND => 

TEST_TOKEN := ASSIGN("and"); 
when TOKEN_OR => 

TEST_TOKEN := ASSIGN("or"); 
when TOKEN_NOT => 

TEST_TOKEN := ASSIGN("not"); 
when TOKEN XOR => 

TEST TOKEN := ASSIGN("xor"); 
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when TOKEN MOD => 
TEST_TOKEN := ASSIGN("mod"); 
when TOKEN_REM => 
TEST_TOKEN := ASSIGN("rem"); 
when TOKEN ABSOLUTE => 
TEST_TOKEN := ASSIGN("abs"); 
when TOKEN ASTERISK => 
TEST_TOKEN := ASSIGN("*"); 
when TOKEN SLASH => 
TEST_TOKEN := ASSIGN("/"); 
when TOKEN EXPONENT => 
TEST_TOKEN := ASSIGN("**"); 
when TOKEN PLUS => 
TEST_TOKEN := ASSIGN("+"); 
when TOKEN_MINUS => 
TEST_TOKEN := ASSIGN("-"); 
when TOKEN AMPERSAND => 
TEST_TOKEN := ASSIGN("&"); 
when TOKEN EQUALS => 
TEST_TOKEN := ASSIGN("="); 
when TOKEN _NOT_EQUALS => 
TEST_TOKEN := ASSIGN("/="); 
when TOKEN LESS THAN => 
TEST_TOKEN := ASSIGN("<"); 
when TOKEN_LESS_THAN_EQUALS => 
TEST_TOKEN := ASSIGN("<="); 
when TOKEN GREATER_THAN => 
TEST_TOKEN := ASSIGN(">"); 
when TOKEN GREATER_THAN_EQUALS => 
TEST_TOKEN := ASSIGN(">="); 
when TOKEN ASSIGNMENT => 
TEST_TOKEN := ASSIGN(":="); 
when TOKEN COMMA => 
TEST_TOKEN := ASSIGN(","); 
when TOKEN SEMICOLON => 
TEST_TOKEN := ASSIGN(";"); 
when TOKEN PERIOD => 
TEST_TOKEN := ASSIGN("."); 
when TOKEN LEFT_PAREN => 
TEST_TOKEN := ASSIGN("("); 
when TOKEN _RIGHT_ PAREN => 
TEST_TOKEN := ASSIGN(")"); 
when TOKEN COLON => 
TEST_TOKEN := ASSIGN(":"); 
when TOKEN _APOSTROPHE => 
TEST_TOKEN := ASSIGN("'"); 
when TOKEN RANGE DOTS => 
TEST_TOKEN := ASSIGN(".."); 
when TOKEN ARROW => 
TEST_TOKEN := ASSIGN("=>"); 
when TOKEN BAR => 
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TEST_TOKEN := ASSIGN("|"); 
when TOKEN BRACKETS => 
TEST_TOKEN := ASSIGN("<>"); 
when TOKEN LEFT BRACKET => 
TEST_TOKEN := ASSIGN("<<"); 
when TOKEN RIGHT BRACKET => 
TEST_TOKEN := ASSIGN(">>"); 
when others => null; 
end case; 
IS SAME := (CURRENT TOKEN = TEST_TOKEN); 
end if; 
if (IS_SAME) then 
HOLD_TOKEN := CURRENT TOKEN; 
TOKEN_SCANNER.CONSUME TOKEN( SOURCE FILE); 
end if; 
return (IS_SAME); 
end MATCH; 


procedure MATCHED TOKEN(TOKEN : out TOKEN SCANNER. TOKEN _RECORD_TYPE) is 
-- pre - TOKEN _MATCHER has been set up and at least one call to the 
== function MATCH has returned TRUE; 
-- post - TOKEN contains the token that caused the last call to MATCH 
= to be TRUE. NOTE - All identifiers are converted to upper case 
== by the token matcher and all reserved words are converted to lower 
== case by the token matcher regardless of the format in the source 
me code. All other token types are uneffected by the token matcher. 
begin 

TOKEN := HOLD TOKEN; 
end MATCHED TOKEN; 


procedure CURRENT _TOKEN(TOKEN : out TOKEN SCANNER. TOKEN RECORD TYPE) is 
-- pre - TOKEN _MATCHER has been set up. 
-- post - TOKEN contains the token that is under the TOKEN SCANNER's 
a read head. 
begin 
TOKEN SCANNER.LOOK_TOKEN(SOURCE FILE, TOKEN); 
end CURRENT TOKEN; 


procedure NEXT_TOKEN(TOKEN : out TOKEN SCANNER.TOKEN RECORD_TYPE) is 
~- pre - TOKEN MATCHER has been set up. 
-- post - TOKEN contains the token that is next to be read by the 
—- TOKEN SCANNERS read head. 
begin 
TOKEN_SCANNER.LOOK AHEAD TOKEN( SOURCE FILE, TOKEN); 
end NEXT TOKEN; 


function LINES CHECKED return positive is 

-- pre - TOKEN_MATCHER has been set up. 

-- post - returns the number of lines of code that have been checked 
=S by the TOKEN MATCHER. 

begin 


2a 


return (TOKEN SCANNER.LINES SCANNED( SOURCE FILE)); 
end LINES CHECKED; 


function VALID _COMMENTS return natural is 
-- pre - TOKEN_MATCHER has been set up. 
-- post - returns the number of “meaningful” comments seen by the 
a TOKEN MATCHER. A “meaningful” comment is defined as a comment 
ee that contains at least one letter or digit. 
begin 
return (TOKEN SCANNER.COMMENTS SCANNED(SOURCE_FILE)); 
end VALID COMMENTS; 


end TOKEN MATCHER; 
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APPENDIX H 
“ADAFLOW” PROGRAM LISTING - TOKEN SCANNER 
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==>) Nees ADAFLOW aie 
-- MODULE NAME: PACKAGE TOKEN_SCANNER aii 
-- FILE NAME: TOKEN .ADS a 


== ‘DATE CREATED: O02 FEB 88 ad 
-- LAST MODIFIED: 26 APR 88 Sc 


-- AUTHOR(S): LT ALBERT J. GRECCO, USN =< 


-~- DESCRIPTION: This package defines the interface to the = 
— token scanner module. am 
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with TEXT_IO; 
package TOKEN SCANNER is 


~~ maximum number of chars per line in file being parsed 
LINESIZE : constant integer := 132; 


ENDFILE : constant character := ASCII.sub; 
ENODLINE : constant character := ASCII.eot; 


a 


-- ADA token classes 

type TOKEN CLASS is (RESERVED WORD, IDENTIFIER, SEPARATOR, NUMERIC LIT, 
DELIMITER, COMMENT, CHARACTER LIT, STRING LIT, 
UNDEF_CHAR, EOF); 


-- record to indicate where a token came from 
type SOURCE RECORD is 


record 
FILE _NAME 2 string( 1. .LINESIZE) := (others => " ~); 
FILE_NAME_SIZE : natural := 0; 
LINE NUMBER : Natural; 


end record; 


record to hold the token built up by the token scanner. the LEXEME is 
-- the actual string for that particular token and LEXEME_SIZE 1s the 
-- number of characters in the lexeme string. SOURCE indicates the 
location in the source file where the token originated. 
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type TOKEN RECORD TYPE is 


record 
TOKEN _TYPE : TOKEN CLASS; 
LEXEME > String(1..LINESIZE) := (others => ' '); 
LEXEME SIZE : natural := 0; 
SOURCE : SOURCE RECORD; 


end record; 


-- raising of any of the following exceptions indicates that an illegal 
-- token has been scanned into the look ahead token. In the case of an 
-- exception, procedure LOOK TOKEN is undefined, while procedure LOOK_ 
-- AHEAD_TOKEN can provide access to the lexeme that raised one of the 
-- scanner exceptions. 

ILLEGAL_IDENTIFIER =: exception; 

ILLEGAL_NUMERIC_LIT : exception; 

ILLEGAL_STRING LIT : exception; 

ILLEGAL CHARACTER > exception; 


procedure SET_UP_TOKEN SCANNER(PARSE FILE : in TEXT_IO.file_ type); 
-- pre - must be called before any other procedure in the token 
ae scanner module. Only one file may be set up at a time. 
== PARSE FILE must be open and rewound before token scanner 
ie Can be set up. 


procedure RELEASE TOKEN SCANNER(PARSE_ FILE : in out TEXT_IO.file_type); 
-- pre - TOKEN SCANNER has been set up. 

-- post - All TOKEN SCANNER interfaces are undefined with the exception 
== of SET_UP_TOKEN_ SCANNER. The TOKEN_SCANNER must be released 

Se prior to main program termination. PARSE FILE is closed. 


procedure LOOK TOKEN(PARSE FILE : in TEXT_I0.file_type; 
TOKEN : out TOKEN _RECORD_TYPE); 
-- pre - scanner has been set up and an exception has not occurred. 


-- post - TOKEN contains the token under the read head in PARSE FILE. 
ae The scanner filters out comments and separators. 


procedure LOOK _AHEAD_TOKEN( PARSE FILE > in TEXT_I0.file_type; 
TOKEN : out TOKEN_RECORD_TYPE); 
-- pre - scanner has been set up. 


-- post - TOKEN contains the next token to come under the read head in 
== PARSE FILE. The scanner filters out comments and separators. 


procedure CONSUME _TOKEN(PARSE FILE : in TEXT_IO.file_type); 
-- pre - scanner has been set up. 

-- post - the read head is advanced one token in PARSE FILE. 
a The scanner filters out comments and separators. 


function LINES SCANNED(PARSE FILE : in TEXT_IO.file_ type) return positive; 
-- pre - scanner has been set up. 

-- post - returns the number of lines in PARSE FILE 

ao that have been scanned by the token scanner. 
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function COMMENTS SCANNED(PARSE FILE : in TEXT_I0.file_type) return natural; 
-- pre - scanner has been set up. 

-- post - returns the number of "meaningful" comments in PARSE FILE 

a that have been scanned by the token scanner. A "meaningful" 

== comment is defined as a comment that contains at least one 

ie letter or digit. 


end TOKEN SCANNER; 
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Somer l TLE: ADAF LOW == 
-- MODULE NAME: PACKAGE TOKEN SCANNER = 
soe LE NAME : TOKEN. ADB ee 


-- DATE CREATED: 02 FEB 88 Ss 
-- LAST MODIFIED: 26 APR 88 a 


-- AUTHOR(S): LT ALBERT J. GRECCO, USN -- 


-- DESCRIPTION: This package contains the procedures which = 
=< implement the TOKEN SCANNER. ag 


—— FSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSseS Sse sess esses seses.__ 


with TEXT_IO; 
package body TOKEN SCANNER is 


CURRENT_TOKEN : TOKEN_RECORD TYPE; 
NEXT_TOKEN : TOKEN_RECORD_TYPE; 
LINE _TOTAL eepOSiLive .= 1; 
COMMENT_TOTAL : natural := 0; 


package BUILD TOKEN PIPE is 
procedure INITIALIZE TOKEN PIPE; 


procedure GET _TOKEN( TEXT FILE : in TEXT_I0.file_type; 
TOKEN : out TOKEN_RECORD TYPE; 
IS_ VALID : out boolean); 
end BUILD_TOKEN PIPE; 


package body BUILD TOKEN PIPE is 
Subtype UPPER_CASE LETTER is character range 'A’..'2'; 
subtype LOWER CASE LETTER is character range ‘a'..'z'; 
subtype UPPER CASE HEX 1s Character range 'A'..'F'; 
subtype LOWER CASE HEX is character range ‘a'..'f'; 


subtype DIGITS TYPE is character range '0'..'9'; 
subtype FORMAT EFFECTOR is character range ASCII.HT..ASCII.CR; 
subtype CHAR _LIT_TYPE 1s Character range ' '..'"'; 


type LOOK _UP_TABLE is array (LOWER_CASE LETTER) of natural; 
type STRING MATRIX is array (positive range 1..63) of string(1..9); 


RESERVED WORD_MATRIX : STRING_MATRIX := 


(("abort Cja( "abs "),("accept "),( "access mye 
("all "),( "and "Car cay, wo PENE mes 
("begin AT Malsvove hy "),("case eye constant. ~ )i, 


Zon 


("declare "),("delay "),( "delta "), (“digits relte 
("do "), ("else "), ("elsif "),( "end nas. 
("entry "),("exception"),( "exit e high eth ae 
("function "),("generic "“),("goto Eye a) 
("in Ped YS "),("limited "),("loop ie 
("mod "),( "new 4 nee ey. nw Oe 
(“of mye OF "), ("others =) t Out ms 
("package "),("pragma "),("private "),("procedure”), 
("raise "),("range "),("record "),("rem Je 
("renames "),("“return "),("reverse "),("select ma 
("separate "),("subtype "),("task "),("terminate"), 
("then "), ("type "),("use "),( "when ae 
("while "),( "with ")3(*xor mys 


RESERVED WORD_HASH ; LOOK_UP_TABLE := 
((1),(09),(11).(13), (18), (24), (26), (0),(28),(0),(0),(31),(33), 
(34),(37),(41),(0),(45),(52),(55),(59),(0),(60),(63),(0),(0)); 

CH : character := ' '; 


CH_HOLD : character := ' '; 

INITIAL_TOKEN : boolean := TRUE; 
PARTIAL_TOKEN : boolean := FALSE; 
TOKEN_WAITING : boolean := FALSE; 


TOKEN_HOLD : TOKEN _RECORD_TYPE; 
package GET_CHAR_PIPE is 
procedure GET_CHARACTER( TEXT FILE in TEXT _I10.file_type; 
CH : out Character); 
end GET_CHAR_PIPE; 


package body GET_CHAR_ PIPE is 
procedure GET CHARACTER(TEXT FILE in TEXT_I0.file_type; 
CH > out character) is 
begin 
if TEXT_IO.END OF FILE( TEXT_FILE) then 
CH := ENDFILE; 
elsif TEXT_IO.END_ OF _LINE(TEXT_FILE) then 
TEXT_I0.SKIP_LINE( TEXT FILE); 
CH := ENDLINE; 
else 
TEXT_I0.get( TEXT FILE, CH); 
end if; 
end GET CHARACTER; 
end GET_CHAR_PIPE; 


procedure INITIALIZE TOKEN PIPE is 


begin 
CH ye TS 
CH_HOLD re yt 
INITIAL TOKEN := TRUE; 
PARTIAL TOKEN := FALSE; 
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TOKEN WAITING := FALSE; 
end INITIALIZE _TOKEN PIPE; 


procedure GET _TOKEN(TEXT FILE : in TEXT I0.file type; 
TOKEN : out TOKEN RECORD_TYPE; 
IS_VALID : out boolean) is 
LEXEME COUNT : positive := 1; 
STATE : positive := 1; 
TEST _LEXEME ; string(1..LINESIZE); 
SHARP_REPLACEMENT : boolean := FALSE; 
QUOTE_REPLACEMENT : boolean := FALSE; 
function IS _RESERVED(TEST_LEXEME : in string) return boolean is 
LEXEME : string(1..9) := (others => ' '); 
IS MATCH : boolean := FALSE; 
ROW : natural; 
INDEX _CHAR : character; 
HASH STOP : natural; 
begin 
if (TEST_LEXEME'LENGTH <= 9) then 
LEXEME(TEST_LEXEME'RANGE) := TEST_LEXEME; 
for I in TEST_LEXEME'RANGE loop 
if ((LEXEME(I) in DIGITS TYPE) or else (LEXEME(I) = '_')) then 
return (FALSE); 
elsif (LEXEME(I) in UPPER CASE LETTER) then 
LEXEME(I) := 
LOWER _CASE_LETTER'VAL(UPPER CASE _LETTER'POS(LEXEME(1)) + 32); 
end if; 
end loop; 
case (LEXEME(1)) is 
mBenein (jk | Qulty ("y foz! => 
return (FALSE); 
when others => 
ROW := RESERVED WORD _HASH(LEXEME(1)); 
if (LEXEME(1) = 'x') then 
HASH STOP := 63; 
else 
INDEX_CHAR := character’ SUCC(LEXEME(1)); 
while (RESERVED WORD HASH( INDEX_CHAR) = 0) loop 
INDEX_CHAR := character'SUCC(INDEX_CHAR); 
end loop; 
HASH STOP := RESERVED WORD _HASH( INDEX CHAR) ; 
end if; 
while ((ROW <= HASH STOP) and then (not IS_MATCH)) loop 
IS MATCH := (LEXEME = RESERVED _WORD_MATRIX(ROW)); 
ROW := ROW + 1; 
end loop; 
return (IS MATCH); 
end case; 
else 
return (FALSE); 
end if; 
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end IS_ RESERVED; 
begin 
TOKEN.LEXEME := (others => ' '); 
TOKEN.SOURCE.FILE NAME := (others => ' ‘'); 
if (INITIAL_TOKEN) then 
GET_CHAR_PIPE.GET_CHARACTER(TEXT_FILE, CH_HOLD); 
INITIAL_TOKEN := FALSE; 
end if; 
1f ((CH /= ENDFILE) and then (not TOKEN WAITING) and then 
(not PARTIAL_TOKEN)) then 
CH := CH_HOLD; 
GET_CHAR_PIPE.GET_CHARACTER( TEXT_FILE, CH_HOLD); 
elsif (PARTIAL_TOKEN) then 
PARTIAL_TOKEN := FALSE; 
end if; 
if TOKEN_WAITING then 
TOKEN := TOKEN _HOLD; 
IS_VALID := TRUE; 
TOKEN WAITING := FALSE; 
elsif ((CH in UPPER_CASE LETTER) or else (CH in LOWER_CASE_LETTER)) then 
TOKEN. TOKEN_TYPE := IDENTIFIER; 
TOKEN.SOURCE.LINE_ NUMBER := LINE_TOTAL; 
TOKEN.SOURCE.FILE_NAME_ SIZE := TEXT_I0.name( TEXT _FILE)*LENGTH; 
TOKEN.SOURCE .FILE NAME(1..TEXT_IO.name(TEXT_FILE)'LENGTH) := 
TEXT_IO0.name(TEXT_FILE); 
TOKEN. LEXEME(LEXEME COUNT) := CH; 
TEST _LEXEME(LEXEME COUNT) := CH; 
loop 
case STATE is 
when 1 => if (({CH_HOLD in UPPER_CASE LETTER) or else 
(CH_HOLD in LOWER_CASE_ LETTER) or else 
(CH_HOLD in DIGITS_TYPE)) then 
LEXEME_ COUNT := LEXEME_COUNT + 1; 
TOKEN.LEXEME(LEXEME COUNT) := CH_HOLD; 
TEST_LEXEME(LEXEME COUNT) := CH_HOLD; 
GET_CHAR_PIPE.GET_CHARACTER(TEXT_FILE, CH_HOLD); 
elsif (CH_HOLD = '_') then 
STATE := 2; 
LEXEME_COUNT := LEXEME_COUNT + 1; 
TOKEN.LEXEME(LEXEME COUNT) := CH_HOLD; 
TEST_LEXEME(LEXEME COUNT) := CH_HOLD; 
GET_CHAR PIPE .GET_CHARACTER( TEXT _FILE, CH_HOLD); 
else 
if (IS_RESERVED( TEST_LEXEME(1..LEXEME COUNT))) then 
TOKEN. TOKEN_TYPE := RESERVED WORD; 
end if; 
TOKEN.LEXEME SIZE := LEXEME COUNT; 
IS _ VALID := TRUE; 
exit; 
end if; 
when 2 => if ((CH_HOLD in UPPER CASE LETTER) or else 
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(CH_HOLD in LOWER_CASE LETTER) or else 
(CH_HOLD in DIGITS _TYPE)) then 
STATE := 1; 
LEXEME COUNT := LEXEME COUNT + 1; 
TOKEN.LEXEME(LEXEME_COUNT) := CH_HOLD; 
TEST_LEXEME(LEXEME COUNT) := CH_HOLD; 
GET_CHAR_PIPE.GET_CHARACTER(TEXT_FILE, CH_HOLD); 
else 
IS _ VALID := FALSE; 
TOKEN.LEXEME SIZE := LEXEME_COUNT; 


exit; 
end if; 
when others => null; 
end case; 
end loop; 


elsif ((CH in FORMAT_EFFECTOR) or else 


(CH = ' ') or else (CH = ENDLINE)) then 

TOKEN. TOKEN TYPE := SEPARATOR; 
TOKEN.SOURCE.LINE NUMBER := LINE TOTAL; 
TOKEN.SOURCE.FILE_NAME_ SIZE := TEXT_IO.name( TEXT _FILE)'LENGTH; 
TOKEN.SOURCE.FILE_NAME(1..TEXT_I10.name(TEXT_FILE)'LENGTH) := 

TEXT _IO.name( TEXT FILE); 
TOKEN.LEXEME(LEXEME COUNT) := CH; 
if (CH = ENDLINE) then 

LINE TOTAL := LINE_TOTAL + 1; 
end if; 
-- go ahead and flush out the rest of the separators as they will! be 
-- discarded anyway 
while ((CH_HOLD in FORMAT_EFFECTOR) or else (CH_HOLD = ’ ') or else 
(CH_HOLD = ENDLINE)) loop 

LEXEME COUNT := LEXEME COUNT + 1; 

TOKEN.LEXEME(LEXEME COUNT) := CH_HOLD; 

if (CH_HOLD = ENDLINE) then 

LINE TOTAL >= LINE TOTAL 4 1; 

end if; 

GET_CHAR_PIPE.GET _CHARACTER( TEXT_FILE, CH HOLD); 
end loop; 
TOKEN.LEXEME SIZE := LEXEME COUNT; 
IS_VALID := TRUE; 


elsif (CH in DIGITS TYPE) then 


TOKEN.TOKEN TYPE := NUMERIC LIT; 
TOKEN.SOURCE.LINE NUMBER := LINE TOTAL; 
TOKEN.SOURCE.FILE NAME SIZE := TEXT_IO.name( TEXT FILE)'LENGTH; 
TOKEN.SOURCE.FILE NAME(1..TEXT_I0.name(TEXT_FILE)'LENGTH) ;= 
TEXT_I0.name( TEXT FILE); 
TOKEN.LEXEME(LEXEME COUNT) := CH; 
loop 
case STATE is 
when 1 => 1f (CH_HOLD in DIGITS _ TYPE) then 
LEXEME COUNT := LEXEME COUNT + 1; 
TOKEN.LEXEME(LEXEME COUNT) := CH HOLD; 
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when 2 => 


GET _CHAR_PIPE.GET_CHARACTER( TEXT_FILE, CH_HOLD); 
elsif (CH_HOLD = ‘.') then 

STATE := 2; 

LEXEME COUNT := LEXEME_COUNT + 1; 

TOKEN. LEXEME(LEXEME COUNT) := CH_HOLD; 

GET_CHAR_PIPE.GET_CHARACTER( TEXT FILE, CH_HOLD); 
elsif ((CH_HOLD "E') or else (CH_HOLD = 'e')) then 

STATE := 17; 

LEXEME COUNT LEXEME COUNT + 1; 

TOKEN.LEXEME(LEXEME COUNT) := CH_HOLD; 

GET_CHAR_PIPE.GET_CHARACTER(TEXT_FILE, CH_HOLD); 
elsif (CH_HOLD = '_') then 

STATE := 9; 

LEXEME COUNT := LEXEME_COUNT + 1; 

TOKEN.LEXEME(LEXEME_COUNT) := CH_HOLD; 

GET_CHAR_PIPE.GET_CHARACTER( TEXT_FILE, CH_HOLD); 


elsif ((CH_HOLD = ‘#') or else (CH_HOLD = ':')) then 
SHARP_REPLACEMENT := (CH_HOLD SEs 
STATE := 10; 


LEXEME_COUNT := LEXEME_COUNT + 1; 
TOKEN. LEXEME(LEXEME COUNT) := CH_HOLD; 
GET CHAR_PIPE.GET_CHARACTER(TEXT_FILE, CH_HOLD); 
elsif ((CH_HOLD in UPPER_CASE_LETTER) or else (CH_HOLD in 
LOWER CASE _LETTER)) then --must be a separator 
--between a numeric literal and an identifier. 
TOKEN.LEXEME SIZE := LEXEME COUNT; 
IS VALID := FALSE; 
exit; 
else 
TOKEN.LEXEME SIZE := LEXEME COUNT; 
IS VALID := TRUE; 
exit; 
end if; 
if (CH_HOLD in DIGITS _TYPE) then 
SVATES j=" 3! 
LEXEME COUNT := LEXEME COUNT + 1; 
TOKEN.LEXEME(LEXEME COUNT) := CH_HOLD; 
GET_CHAR_PIPE.GET_CHARACTER( TEXT FILE, CH_HOLD); 
elsif (CH_HOLD = '.') then --test for range dots 
TOKEN.LEXEME(LEXEME COUNT) := ' '; 
TOKEN.LEXEME SIZE := LEXEME COUNT - 1; 
IS VALID := TRUE; 
TOKEN _HOLD.TOKEN_TYPE := DELIMITER; 
TOKEN _HOLD.LEXEME(1..2) := ".."; 
TOKEN_HOLD.LEXEME SIZE := 2; 
TOKEN _HOLD.SOURCE.LINE_NUMBER := LINE_TOTAL; 
TOKEN _HOLD.SOURCE.FILE NAME SIZE := 
TEXT_IO.name( TEXT _FILE)'LENGTH; 
TOKEN HOLD.SOURCE.FILE NAME(1..TEXT_IO. 
name( TEXT FILE)'LENGTH) := TEXT I10.name( TEXT FILE); 
GET _CHAR_PIPE.GET CHARACTER( TEXT FILE, CH_HOLD); 
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TOKEN WAITING := TRUE; 
exit; 
else 
TOKEN.LEXEME SIZE := LEXEME COUNT; 
PS _VACID == PAUSE: 
exit; 
end if; 
when 3 => if (CH_HOLD in DIGITS TYPE) then 
LEXEME COUNT := LEXEME COUNT + 1; 
TOKEN. LEXEME(LEXEME COUNT) := CH_HOLD; 
GET _CHAR_PIPE.GET CHARACTER(TEXT_FILE, CH_HOLD) ; 
elsif ((CH_HOLD = ‘'E’) or else (CH_HOLD = ‘e')) then 
STATE := 4; 
LEXEME COUNT := LEXEME COUNT + 1; 
TOKEN.LEXEME(LEXEME_COUNT) := CH_HOLD; 
GET_CHAR_ PIPE .GET CHARACTER( TEXT FILE, CH_HOLD); 
elsif (CH_HOLD = ‘'_') then 
STATE := 5; 
LEXEME COUNT := LEXEME COUNT + 1; 
TOKEN.LEXEME(LEXEME COUNT) := CH_HOLD; 
GET_CHAR_PIPE.GET_CHARACTER( TEXT_FILE, CH_HOLD) ; 
elsif ((CH_HOLD in UPPER_CASE LETTER) or else (CH_HOLD in 
LOWER _CASE_LETTER)) then 
TOKEN.LEXEME SIZE := LEXEME COUNT; 
IS_VALID := FALSE; 
exit; 
else 
TOKEN.LEXEME SIZE := LEXEME COUNT; 
IS VALID := TRUE; 


exit; 
end if; 
when 4 => if ({CH_HOLD = ‘+') or else (CH_HOLD = ‘~-')) then 
STATE 2= 6; 


LEXEME COUNT := LEXEME_COUNT + 1; 
TOKEN.LEXEME(LEXEME COUNT) := CH_HOLD; 
GET _CHAR_PIPE.GET_CHARACTER( TEXT FILE, CH_HOLD); 
elsif (CH_HOLD in DIGITS TYPE) then 
STATE := 7; 
LEXEME COUNT := LEXEME_COUNT + 1; 
TOKEN.LEXEME(LEXEME COUNT) := CH_HOLD; 
GET_CHAR_PIPE.GET_CHARACTER(TEXT_FILE, CH_HOLD); 
else 
TOKEN.LEXEME SIZE := LEXEME COUNT; 
IS VALID := FALSE; 
exit; 
end if; 
when 5|6{8{9 => if (CH_HOLD in DIGITS TYPE) then 
case STATE is 
when § => STATE 
when 6{8 => STATE := 7; 
when 9 => STATE 


ul 
w 


H 
— 
we 
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when others => null; 
end case; 
LEXEME COUNT := LEXEME COUNT + 1; 
TOKEN.LEXEME(LEXEME COUNT) := CH_HOLD; 
GET_CHAR_PIPE.GET_CHARACTER(TEXT_FILE, CH_HOLD); 
else 
TOKEN.LEXEME SIZE := LEXEME COUNT; 
TS VALID := FALSE; 
exit; 
end if; 
when 7 => if (CH_HOLD in DIGITS TYPE) then 
LEXEME COUNT := LEXEME COUNT + 1; 
TOKEN.LEXEME(LEXEME COUNT) := CH_HOLD; 
GET_CHAR_PIPE.GET _CHARACTER(TEXT_FILE, CH_HOLD); 
elsif (CH_HOLD = '_') then 
STATE 2= 8: 
LEXEME COUNT := LEXEME_COUNT + 1; 
TOKEN.LEXEME(LEXEME COUNT) := CH_HOLD; 
GET_CHAR_ PIPE.GET_CHARACTER( TEXT FILE, CH_HOLD); 
elsif ((CH_HOLD in UPPER CASE LETTER) or else (CH_HOLD in 
LOWER_CASE_LETTER)) then 
TOKEN.LEXEME SIZE := LEXEME_COUNT; 
TS VALID := FALSE; 
exit; 
else 
TOKEN.LEXEME SIZE := LEXEME COUNT; 
IS_ VALID := TRUE; 
exit; 
end if; 
when 10 => if ((CH_HOLD in DIGITS TYPE) or else 
(CH_HOLD in UPPER_CASE_HEX) or else 
(CH HOLD in LOWER _CASE_HEX)) then 
SUAUE ge iis 
LEXEME COUNT := LEXEME_COUNT + 1; 
TOKEN.LEXEME(LEXEME COUNT) := CH_HOLD; 
GET_CHAR_PIPE.GET_CHARACTER( TEXT_FILE, CH_HOLD); 
elsif ((CH_HOLD = '=') and then (SHARP_REPLACEMENT)) then 
SHARP_REPLACEMENT := FALSE; 
TOKEN.LEXEME(LEXEME COUNT) := ' '; 
TOKEN.LEXEME SIZE := LEXEME COUNT - 1; 
IS VALID := TRUE; 
TOKEN HOLD.TOKEN TYPE := DELIMITER; 
TOKEN HOLD.LEXEME(1..2) := "i="; 
TOKEN_HOLD.LEXEME SIZE := 2; 
TOKEN _HOLD.SOURCE.LINE_ NUMBER := LINE_TOTAL; 
TOKEN HOLD.SOURCE.FILE NAME SIZE := 
TEXT [O.name( TEXT FILE)'LENGTH; 
TOKEN HOLD.SOURCE.FILE_NAME(1..TEXT IO. 
name( TEXT FILE)'LENGTH) := TEXT_IO.name( TEXT FILE); 
GET CHAR PIPE.GET CHARACTER( TEXT FILE, CH HOLD); 
TOKEN WAITING := TRUE; 
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Oxit; 
else 
TOKEN.LEXEME SIZE := LEXEME COUNT; 
IS _ VALID := FALSE; 
exit; 
end if; 
when 11 => 1f ((CH_HOLD in DIGITS TYPE) or else 
(CH_HOLD in UPPER_CASE HEX) or else 
(CH_HOLD in LOWER _CASE_HEX)) then 
LEXEME COUNT := LEXEME COUNT + 1; 
TOKEN.LEXEME(LEXEME COUNT) := CH_HOLD; 
GET CHAR PIPE.GET CHARACTER( TEXT FILE, CH_HOLD); 
elsif (CH_HOLD = '.') then 
STATE := 14; 
LEXEME COUNT := LEXEME COUNT + 1; 
TOKEN.LEXEME(LEXEME COUNT) := CH_HOLD; 
GET_CHAR_PIPE.GET_CHARACTER(TEXT_FILE, CH_HOLD); 
elsif (CH_HOLD = '_') then 
STATE := 12; 
LEXEME COUNT := LEXEME COUNT + 1; 
TOKEN.LEXEME(LEXEME COUNT) := CH_HOLD; 
GET_CHAR_PIPE.GET_CHARACTER(TEXT_FILE, CH_HOLD) ; 
elsif (((CH_HOLD = '#') and (not SHARP_REPLACEMENT)) or 
else ((CH_HOLD = ':') and SHARP_REPLACEMENT)) then 
SIATE se. 10% 
LEXEME COUNT := LEXEME_COUNT + 1; 
TOKEN.LEXEME(LEXEME COUNT) := CH_HOLD; 
GET_CHAR_PIPE.GET CHARACTER(TEXT_FILE, CH HOLD); 
else 
TOKEN.LEXEME SIZE := LEXEME COUNT; 
IS_VALID := FALSE; 
exit; 
end if; 
when 12|14)16 => if ((CH_HOLD in DIGITS _TYPE) or else 
(CH_HOLD in UPPER_CASE HEX) or else 
(CH_HOLD in LOWER_CASE_HEX)) then 
case STATE is 
when 12 => STATE 
when 14|16 => STATE : 
when others => null; 
end case; 
LEXEME COUNT := LEXEME COUNT + 1; 
TOKEN.LEXEME(LEXEME COUNT) := CH_HOLD; 
GET_CHAR_PIPE.GET_CHARACTER( TEXT FILE, CH_HOLD); 
else 
TOKEN.LEXEME SIZE := LEXEME COUNT; 
IS VALID := FALSE; 


11; 
Se 


Oxi; 
end if; 
when 13 => if ((CH_HOLD = 'E') or else (CH_HOLD = 'e')) then 
STATE := 17; 
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LEXEME COUNT := LEXEME_COUNT + 1; 
TOKEN.LEXEME(LEXEME COUNT) := CH_HOLD; 
GET_CHAR_PIPE.GET CHARACTER( TEXT_FILE, CH_HOLD); 
elsif ((CH_HOLD in UPPER_CASE_LETTER) or else (CH_HOLD in 
LOWER_CASE_LETTER)) then 
TOKEN.LEXEME SIZE := LEXEME COUNT; 
IS_ VALID := FALSE; 
exit; 
else 
TOKEN.LEXEME_ SIZE := LEXEME_COUNT; 
IS_VALIO := TRUE; 
exit; 
end if; 
when 15 => if ((CH_HOLD in DIGITS _TYPE) or else 
(CH_HOLD in UPPER_CASE HEX) or else 
(CH_HOLD in LOWER_CASE_HEX)) then 
LEXEME_COUNT := LEXEME COUNT + 1; 
TOKEN.LEXEME(LEXEME_COUNT) := CH_HOLD; 
GET_CHAR_PIPE.GET_CHARACTER( TEXT FILE, CH HOLD); 
elsif (CH_HOLD = '_') then 
STATE := 16; 
LEXEME COUNT := LEXEME COUNT + 1; 
TOKEN.LEXEME(LEXEME COUNT) := CH_HOLO; 
GET_CHAR_PIPE.GET_CHARACTER( TEXT_FILE, CH_HOLD); 
elsif (((CH_HOLD = '#') and (not SHARP_REPLACEMENT)) or 
else ((CH_HOLD = ':') and SHARP_REPLACEMENT)) then 
STATE “3= 1a; 
LEXEME COUNT := LEXEME_COUNT + 1; 
TOKEN.LEXEME(LEXEME_COUNT) := CH_HOLO; 
GET_CHAR_PIPE.GET_CHARACTER( TEXT_FILE, CH_HOLD); 
else 
TOKEN.LEXEME SIZE := LEXEME COUNT; 
TSVAEIO. ==" FALSE; 


exit; 
end if; 
when 17 => if (CH_HOLD = '+') then 
STATE 2=76; 


LEXEME_COUNT := LEXEME_COUNT + 1; 
TOKEN.LEXEME(LEXEME_COUNT) := CH_HOLO; 
GET_CHAR_PIPE.GET_CHARACTER(TEXT_FILE, CH_HOLD); 
elsif (CH_HOLD in DIGITS TYPE) then 
STATE <= 7: 
LEXEME_COUNT := LEXEME COUNT + 1; 
TOKEN.LEXEME(LEXEME COUNT) := CH_HOLD; 
GET_CHAR_PIPE.GET_CHARACTER(TEXT_FILE, CH _HOLD); 
else 
TOKEN.LEXEME SIZE := LEXEME COUNT; 
IS VALID := FALSE; 
exit; 
end if; 
when 18 => if ((CH_HOLD = ‘E’') or else (CH_HOLD = ‘e')) then 
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STATE := 4; 
LEXEME COUNT := LEXEME_COUNT + 1; 
TOKEN.LEXEME(LEXEME COUNT) := CH_HOLD; 


GET_CHAR_PIPE.GET CHARACTER(TEXT FILE, CH_HOLD); 
elsif ((CH_HOLD in UPPER_CASE_LETTER) or else (CH_HOLD in 


LOWER CASE _LETTER)) then 
TOKEN.LEXEME SIZE := LEXEME_ COUNT; 
IS_VALID := FALSE; 
exit; 

else 
TOKEN.LEXEME SIZE := LEXEME COUNT; 
IS VALID := TRUE; 


exit; 
end if; 
when others => null; 
end case; 
end loop; 
elsif (CH = ''') then 


TOKEN.SOURCE .LINE_NUMBER := LINE TOTAL; 


TOKEN.SOURCE.FILE NAME SIZE := TEXT_I0.name( TEXT FILE) ‘LENGTH; 
TOKEN.SOURCE.FILE_NAME(1..TEXT_IO0.name( TEXT FILE)'LENGTH) := 


TEXT_I0.name( TEXT FILE); 
TOKEN.LEXEME(LEXEME COUNT) := CH; 
IS VALID := TRUE; 
loop 
case STATE is 
when 1 => if (CH_HOLD in CHAR LIT_TYPE) then 
STATE := 2; 
LEXEME COUNT := LEXEME COUNT + 1; 
TOKEN.LEXEME(LEXEME COUNT) := CH_HOLD; 
CH <= CH HOLD: 


GET_CHAR_PIPE.GET_CHARACTER(TEXT_FILE, CH HOLD); 


else 
TOKEN. TOKEN TYPE := DELIMITER; 
TOKEN.LEXEME SIZE := LEXEME COUNT; 
exit; 

end if; 

when 2 => if (CH_HOLD = ''') then 

TOKEN. TOKEN TYPE := CHARACTER_LIT; 
LEXEME COUNT := LEXEME_COUNT + 1; 
TOKEN.LEXEME(LEXEME COUNT) := CH HOLD; 
TOKEN.LEXEME SIZE := LEXEME COUNT; 


GET _CHAR_PIPE.GET_CHARACTER( TEXT FILE, CH_HOLD); 


exit; 

else 
TOKEN. TOKEN TYPE := DELIMITER; 
PARTIAL_TOKEN := TRUE; 
TOKEN.LEXEME(LEXEME COUNT) := ' '; 
TOKEN.LEXEME SIZE := LEXEME COUNT - 1; 
exit; 

end if; 
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when others => null; 


end Case; 
end loop; 
elsif ((CH = ‘&') or else (CH = '(') or else (CH = ')') or else 
(CH = '*') or else (CH = '+') or else (CH = ',") or else 
(CH = *-") or elseu(CHl= 2") or elseu(th 97" \Ronietse 
(CH = ":") or else (Ciig= 955) Ronse lcoucch! =") Oar else 
(CH = '=") or else (CH=) "> jeor elise (GH - "| )morsetsem( GH = 9)! ))ethen 


TOKEN.TOKEN TYPE := DELIMITER; 
TOKEN.SOURCE.LINE NUMBER := LINE_TOTAL; 
TOKEN. SOURCE .FILE_NAME_SIZE := TEXT_IO.name( TEXT FILE) 'LENGTH; 
TOKEN. SOURCE.FILE_NAME(1..TEXT_IO.name(TEXT_FILE)'LENGTH) := 
TEXT_I0.name( TEXT_FILE); 
IS VALID := TRUE; 
TOKEN.LEXEME(LEXEME COUNT) := CH; 
case CH_HOLD is 
when '.' => if (CH = '.’) then 
LEXEME COUNT := LEXEME COUNT + 1; 
TOKEN.LEXEME(LEXEME COUNT) := CH_HOLD; 
GET_CHAR_PIPE.GET_CHARACTER( TEXT_FILE, CH_HOLD); 
end if; 
when '** => 1f (CH = '**) then 
LEXEME COUNT := LEXEME_COUNT + 1; 
TOKEN.LEXEME(LEXEME COUNT) := CH_HOLD; 
GET_CHAR_PIPE.GET_CHARACTER( TEXT_FILE, CH_HOLD); 
end if; 
when '=' => if ((CH = ':') or else (CH = '/') or else (CH = '>') or 
else (CH = '<')) then 
LEXEME COUNT := LEXEME_COUNT + 1; 
TOKEN. LEXEME(LEXEME COUNT) := CH_HOLD; 
GET CHAR _PIPE.GET CHARACTER({ TEXT FILE, CH HOLD); 


end if; 
when '>' => if ((CH = '<') or else (CH = '>') or 
else (CH = ‘'=')) then 


LEXEME COUNT := LEXEME COUNT + 1; 
TOKEN.LEXEME(LEXEME COUNT) := CH_HOLD; 
GET_CHAR_PIPE.GET CHARACTER(TEXT_FILE, CH_HOLD); 
end if; 
when ‘<' => if (CH = '<') then 
LEXEME COUNT := LEXEME COUNT + 1; 
TOKEN.LEXEME(LEXEME COUNT) := CH_HOLD; 
GET_CHAR_PIPE.GET CHARACTER( TEXT FILE, CH_HOLD); 
end if; 
when '-' => if (CH = '-') then 
TOKEN. TOKEN TYPE := COMMENT; 
LEXEME COUNT := LEXEME COUNT + 1; 
TOKEN .LEXEME(LEXEME COUNT) := CH_HOLD; 
GET CHAR PIPE .GET_CHARACTER( TEXT FILE, CH_HOLD); 
while ((CH_HOLD /= ENDLINE) and 
(CH HOLD /= ENDFILE)) loop 
LEXEME COUNT := LEXEME COUNT + 1; 
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TOKEN.LEXEME(LEXEME COUNT) := CH_HOLD; 
GET_CHAR_PIPE.GET CHARACTER( TEXT FILE, CH_HOLD); 
end loop; 
end if; 
when others => null; 
end Case; 
TOKEN.LEXEME_SIZE := LEXEME COUNT; 
elsif ((CH = '"') or elise (CH = '%')) then 
TOKEN. TOKEN TYPE := STRING LIT; 
TOKEN.SOURCE.LINE_ NUMBER := LINE TOTAL; 
TOKEN.SOURCE.FILE NAME SIZE := TEXT_IO0.name(TEXT_FILE)'LENGTH; 
TOKEN. SOURCE .FILE NAME(1..TEXT_IO.name( TEXT_FILE)'LENGTH) := 
TEXT_I0.name( TEXT_FILE); 
TOKEN.LEXEME(LEXEME COUNT) := CH; 
QUOTE REPLACEMENT := (CH = °%'); 
loop 
case STATE is 
when 1 => if (((CH_HOLD = '"') and (not QUOTE_REPLACEMENT)) or eise 
((CH_HOLD = '%') and QUOTE REPLACEMENT)) then 
STATE := 2; 
LEXEME_COUNT := LEXEME_COUNT + 1; 
TOKEN.LEXEME(LEXEME COUNT) := CH_HOLD; 
GET_CHAR_PIPE .GET_CHARACTER( TEXT_FILE, CH_HOLD); 
elsif (CH_HOLD in CHAR LIT_TYPE) then 
if ((QUOTE_REPLACEMENT and (CH_HOLD /= '%')) or else 
((mot(QUOTE _REPLACEMENT)) and (CH_HOLD /= ‘"'))) then 
STATE := 4; 
LEXEME COUNT := LEXEME_COUNT + 1; 
TOKEN.LEXEME(LEXEME COUNT) := CH_HOLD; 
GET_CHAR_PIPE .GET_CHARACTER( TEXT_FILE, CH_HOLD); 
else 
TOKEN.LEXEME SIZE := LEXEME_COUNT; 
IS VALID ;= FALSE; 
exit; 
end if; 
else 
TOKEN.LEXEME SIZE := LEXEME COUNT; 
TS _ VALID := FALSE; 
exit; 
end if; 
when 2 => if (((CH_HOLD = '"') and (not QUOTE _REPLACEMENT)) or else 
((CH_HOLD = *%') and QUOTE_REPLACEMENT)) then 
STATE := 3; 
LEXEME_COUNT := LEXEME COUNT + 1; 
TOKEN .LEXEME(LEXEME COUNT) := CH_HOLD; 
GET_CHAR_PIPE.GET_CHARACTER( TEXT_FILE, CH_HOLD); 
else 
TOKEN.LEXEME SIZE := LEXEME_ COUNT; 
IS VALID := TRUE; 
exit; 
end if; 
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when 3 => if (((CH_HOLD = '"') and (not QUOTE _REPLACEMENT)) or else 
((CH_HOLD = '%') and QUOTE _REPLACEMENT)) then 
LEXEME COUNT := LEXEME COUNT + 1; 
TOKEN.LEXEME(LEXEME COUNT) := CH_HOLD; 
TOKEN.LEXEME SIZE := LEXEME COUNT; 
GET_CHAR_PIPE.GET CHARACTER(TEXT_FILE, CH HOLD); 
exit; 
elsif (CH_HOLD in CHAR _LIT_TYPE) then 
if ((QUOTE REPLACEMENT and (CH_HOLD /= '%')) or else 
((not(QUOTE_REPLACEMENT)) and (CH_HOLD /= '"'))) then 
STATE := 4; 
LEXEME COUNT := LEXEME COUNT + 1; 
TOKEN.LEXEME(LEXEME_COUNT) := CH_HOLD; 
GET CHAR _PIPE.GET CHARACTER(TEXT_FILE, CH HOLD); 
else 
TOKEN.LEXEME SIZE := LEXEME COUNT; 
IS VALID := FALSE; 
exit; 
end if; 
else 
TOKEN.LEXEME SIZE := LEXEME_COUNT; 
IS_ VALID := FALSE; 
exit; 
end if; 
when 4 => if (((CH_HOLD = '"') and (not QUOTE _REPLACEMENT)) or else 
((CH_HOLD = '%') and QUOTE_REPLACEMENT)) then 
STATES s= "2: 
LEXEME COUNT := LEXEME_COUNT + 1; 
TOKEN.LEXEME(LEXEME COUNT) := CH_HOLD; 
GET_CHAR_PIPE.GET_CHARACTER(TEXT_FILE, CH_HOLD); 
elsif (CH_HOLD in CHAR_LIT_TYPE) then 
if ((QUOTE REPLACEMENT and (CH_HOLD /= '%')) or else 
((not(QUOTE _REPLACEMENT)) and (CH_HOLD /= '"'))) then 
LEXEME_ COUNT := LEXEME COUNT + 1; 
TOKEN.LEXEME(LEXEME COUNT) := CH_HOLD; 
GET_CHAR_PIPE.GET_CHARACTER( TEXT FILE, CH_HOLD); 
else 
TOKEN.LEXEME SIZE := LEXEME COUNT; 
IS VALID := FALSE; 
exit; 
end if; 
else 
TOKEN.LEXEME SIZE := LEXEME COUNT; 
IS_VALID := FALSE; 


exit; 
end if; 
when others => null; 
end case; 
end loop; 


elsif (CH = ENDFILE) then 
TOKEN. TOKEN TYPE :- EOF; 
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TOKEN.SOURCE.LINE NUMBER := LINE TOTAL; 
TOKEN.SOURCE .FILE_NAME SIZE := TEXT_IO.name(TEXT_FILE)'LENGTH; 
TOKEN.SOURCE.FILE NAME(1..TEXT_IO0.name( TEXT FILE)'LENGTH) := 
TEXT_I0.name(TEXT_FILE); 
TOKEN.LEXEME(LEXEME COUNT) := CH; 
TOKEN.LEXEME SIZE := LEXEME COUNT; 
IS_VALID := TRUE; 
else -- character is not defined in ADA 
TOKEN. TOKEN_TYPE := UNDEF CHAR; 
TOKEN.SOURCE.LINE NUMBER := LINE TOTAL; 
TOKEN.SOURCE .FILE_NAME_SIZE := TEXT_IO.name( TEXT _FILE)'LENGTH; 
TOKEN.SOURCE.FILE NAME(1..TEXT_IO.name(TEXT_FILE)'LENGTH) := 
TEXT_IO0.name(TEXT_FILE); 
TOKEN.LEXEME(LEXEME COUNT) := CH; 
TOKEN.LEXEME SIZE := LEXEME_COUNT; 
IS_ VALID := FALSE; 
end if; 
end GET_TOKEN; 
end BUILD _TOKEN_ PIPE; 


function VALID_COMMENT(TOKEN : in TOKEN_RECORD_TYPE) return boolean is 
-- pre - TOKEN is a comment. 
-- post - if the lexeme of the comment contains at least one letter or 
a digit then VALID_COMMENT is true, else VALID_COMMENT is false. 
subtype UPPER _CASE_LETTER is character range 'A'..'2Z'; 
subtype LOWER CASE_LETTER is character range ‘a'..'z'; 
subtype DIGITS_TYPE is character range '0'..'9'; 
IS_VALID : boolean := FALSE; 
LEXEME COUNT : positive := 3; 
begin 
while ((not IS_VALID) and (LEXEME_COUNT <= TOKEN.LEXEME_SIZE)) loop 
IS_VALID := ((TOKEN.LEXEME(LEXEME COUNT) in UPPER_CASE_LETTER) or else 
(TOKEN.LEXEME(LEXEME_COUNT) in LOWER _CASE_ LETTER) or else 
(TOKEN.LEXEME(LEXEME_COUNT) in DIGITS TYPE)); 
LEXEME COUNT := LEXEME_COUNT + 1; 
end loop; 
return IS VALID; 
end VALID COMMENT; 


procedure SET_UP_TOKEN_SCANNER(PARSE FILE : in TEXT_I0.file_type) is 
-- pre - must be called before any other procedure in the TOKEN_ 
== SCANNER module. only one file may be set up at a time. 
ae PARSE FILE must be open and rewound before TOKEN SCANNER 
i can be set up. 
IS_VALID : boolean; 
begin 
LINE TOTAL := 1 
COMMENT TOTAL 0; 
BUILD TOKEN PIPE.INITIALIZE_TOKEN PIPE; 
BUILD_TOKEN_PIPE.GET TOKEN(PARSE FILE, NEXT_TOKEN, IS VALID); 
while (IS VALID and ((NEXT TOKEN.TOKEN_TYPE = SEPARATOR) or else 


iu we 
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(NEXT TOKEN. TOKEN TYPE = COMMENT))) loop 
if (NEXT_TOKEN.TOKEN_TYPE = COMMENT) then 
if (VALID_COMMENT(NEXT_TOKEN)) then 
COMMENT_TOTAL := COMMENT TOTAL + 1; 
end if; 
end if; 
BUILD TOKEN PIPE .GET_TOKEN( PARSE FILE, NEXT_TOKEN, IS VALID); 
end loop; 
if (IS_VALID) then 
CONSUME_TOKEN(PARSE_FILE); 
else 
case (NEXT_TOKEN.TOKEN_TYPE) is 
when IDENTIFIER => raise ILLEGAL_IDENTIFIER; 
when NUMERIC _LIT => raise ILLEGAL_NUMERIC_LIT; 
when STRING LIT => raise ILLEGAL_STRING LIT; 
when UNDEF CHAR => raise ITLLEGAL_CHARACTER; 
when others => null; 
end case; 
end if; 
end SET_UP_TOKEN_SCANNER; 


procedure RELEASE _TOKEN_SCANNER(PARSE_ FILE : in out TEXT_I0O.file_type) is 
-~ pre - TOKEN SCANNER has been set up. 
-- post - All TOKEN SCANNER interfaces are undefined with the exception of 
=< SET_UP_TOKEN_SCANNER. The TOKEN SCANNER must be released prior to 
— main program termination, PARSE FILE is closed. 
begin 
TEXT_I0.close(PARSE_FILE); 
end RELEASE TOKEN SCANNER; 


procedure LOOK_TOKEN(PARSE FILE : in TEXT_IO.file_ type; 
TOKEN : out TOKEN _RECORD_TYPE) is 

-- pre - scanner has been set up and an exception has not occurred. 
-- post - TOKEN contains the token under the read head in PARSE FILE. 
a The scanner filters out comments and separators. 
begin 

TOKEN := CURRENT TOKEN; 
end LOOK_TOKEN; 


procedure LOOK_AHEAD_TOKEN(PARSE FILE : in TEXT_I0.file type; 
TOKEN : out TOKEN _RECORD_TYPE) is 
-- post - TOKEN contains the next token to come under the read head in 
= PARSE FILE. The scanner filters out comments and separators. 
begin 
TOKEN := NEXT_TOKEN; 
end LOOK AHEAD TOKEN; 


procedure CONSUME TOKEN(PARSE FILE : in TEXT I10.file_type) is 
-- pre - the scanner has been set up. 

-- post - the read head is advanced one token in PARSE FILE. 
ai The scanner filters out comments and separators. 
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IS VALID : boolean; 
TEMP_TOKEN : TOKEN_RECORD_TYPE; 
begin 
CURRENT TOKEN := NEXT_TOKEN; 
if (NEXT_TOKEN. TOKEN TYPE /= EOF) then 
BUILD TOKEN PIPE.GET_TOKEN(PARSE FILE, TEMP_TOKEN, IS VALID); 
while (IS_VALID and ((TEMP_TOKEN.TOKEN_TYPE = SEPARATOR) or else 
(TEMP_TOKEN. TOKEN _TYPE = COMMENT))) loop 
if (TEMP_TOKEN. TOKEN TYPE = COMMENT) then 
if (VALID_COMMENT(TEMP_TOKEN)) then 
COMMENT TOTAL := COMMENT TOTAL + 1; 
end if; 
end if; 
BUILD TOKEN PIPE.GET_TOKEN(PARSE FILE, TEMP_TOKEN, IS VALID); 
end loop; 
if (not(IS_VALID)) then 
case (NEXT_TOKEN.TOKEN_TYPE) is 
when IDENTIFIER => raise ILLEGAL_IDENTIFIER; 
when NUMERIC _LIT => raise ILLEGAL_NUMERIC_LIT; 
when STRING LIT => raise ILLEGAL STRING LIT; 
when UNDEF _CHAR => raise ILLEGAL_CHARACTER; 


when others => null; 
end case; 
else 
NEXT TOKEN := TEMP_TOKEN; 
end if; 
end if; 


end CONSUME TOKEN; 


function LINES SCANNED( PARSE FILE : in TEXT_IO.file_ type) return positive is 
-- post - returns the number of lines in PARSE FILE 
i that have been scanned by the token scanner. 
begin 
return CURRENT TOKEN.SOURCE.LINE_ NUMBER; 
end LINES SCANNED; 


function COMMENTS SCANNED(PARSE FILE : 1n TEXT_IO.file type) 
return natural is 
-~ pre - scanner has been set up. 
-- post - returns the number of “meaningful” comments in PARSE FILE 
Se that have been scanned by the token scanner. A "meaningful" 
as comment is defined as a comment that contains at least one 
a letter or digit. 
begin 
return COMMENT TOTAL; 
end COMMENTS SCANNED; 


end TOKEN SCANNER; 
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APPENDIX I 
“ADAFLOW” PROGRAM LISTING - GENERIC PACKAGES 


—~—-SFSFSSSSSSSSSSSE SSE SSSSSESSESSESESTSSSSSSSSSSESSSSSSSESSSSSSSSESESSISSESEBSE_ 


==" TLAEE: ADAFLOW J 


-- MODULE NAME: PACKAGE GENERIC_LIST ae 
-- FILE NAME: LIST.ADA mo 


-- DATE CREATED: 31 MAR 88 ae 
-- LAST MODIFIED: 28 APR 88 pom 


== AUTHOR(S): LT ALBERT J. GRECCO, USN a 


-- DESCRIPTION: This package defines the operations as 
== available on the abstract data type LIST. == 


—a— SSSFSSSSSSSESISSSS SSS SSS SSS SESS SSESSSSSSSVSSSSSSISSSESSSSSSSVSATESVISBFI_ 


generic 
type ITEM_TYPE is private; 
package GENERIC_LIST is 


type LIST is limited private; 


LIST OVERFLOW : exception; 
LIST _UNDERFLOW : exception; 


-- Operations: If the list is not empty, then one of the nodes is designated 

= as the current node. OQcaasionally, in the postcondition, it is necessary 
a= to refer to the list of the current node as they were immediately before 

ie execution of the operation. L-pre and c-pre, respectively, are employed 

aS for these references. 


procedure FIND FIRST(L : in out LIST); 

-- pre - The list L is not empty. 

-- post - The first node is the current node. 

-- exceptions raised - LIST_UNDERFLOW if L is empty. 


procedure FIND NEXT(L : in out LIST); 
-- pre - The list L is not empty and the last node is not the current node. 
post - c-next in L is the current node. 
- exceptions raised - LIST _UNDERFLOW if L is empty. 
a - LIST_OVERFLOW if the last node is the current node. 
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procedure FIND PREVIOUS(L : in out LIST); 

-- pre - The list L is not empty and the first node is not the current node. 
-- post - c-prior in L 1s the current node. 

-- exceptions raised - LIST_UNDERFLOW if L is empty or c is the first node. 


procedure FIND _LAST(L : in out LIST); 

-- pre - The list L is not empty. 

-- post - The last node in L is the current node. 

-- exceptions raised - LIST_UNDERFLOW if L is empty. 


procedure RETRIEVE(L : in LIST; ITEM : out ITEM_TYPE); 

~- pre - The list L is not empty. 

-- post - ITEM contains the value of the element in the current node. 
-- exceptions raised - LIST _UNDERFLOW if L is empty. 


procedure UPDATE(L : in out LIST; ITEM : in ITEM_TYPE); 

-- pre - The list L is not empty. 

-- post - The current node in L contains ITEM as its element. 
-- exceptions raised - LIST_UNDERFLOW if L is empty. 


procedure INSERT(L : in out LIST; ITEM : in ITEM_TYPE); 

-- pre - The number of nodes in L has not reached its bound. 

-- post - A node containing ITEM is the last node in the list, and the last 
oS node in L-pre, if any, is its predecessor. The node containing 
as ITEM is the current node. 

-- exceptions raised - LIST_OVERFLOW if L has reached its bound. 


procedure DELETE(L : in out LIST); 

-- pre - The list L is not empty. 

-- post - c-pre in not in the list L. If c-pre was the first node, 

i then c-next, if it exists, is the successor of c-prior. If the 
=e list L is not empty, then the last node is the current node. 

-- exceptions raised - LIST_UNDERFLOW if L is empty. 


function SIZE_OF(L : in LIST) return natural; 
-- post - SIZE_OF is the number of nodes in list L. 


function EMPTY(L : in LIST) return boolean; 
-- post - If the list L has no nodes then EMPTY is true, else EMPTY is 
=o false. 


function FULL(L : in LIST) return boolean; 
-- post - If the number of nodes in the list L has reached the maximum 
=o allowed, then FULL is true, else FULL is false. 


function FIRST(L : in LIST) return boolean; 

-- pre - The list L is not empty. 

-- post - If the first node is the current node in L then FIRST is true, else 
BS FIRST is false. 

-- exceptions raised - LIST UNDERFLOW if L is empty. 
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function LAST(L : in LIST) return boolean; 

-- pre - The list L is not empty. 

-- post - If the last node is the current node in L then LAST is true, else 
aS LAST is false. 

-- exceptions raised - LIST_UNDERFLOW if L 1s empty. 


procedure CREATE(L : in out LIST; SUCCESS : out boolean); 
-- post - If a list L can be created then L exists and iS empty, and SUCCESS 


aa is TRUE else SUCCESS is FALSE. 


procedure DISPOSE(L : in out LIST); 
-- post - L-pre does not exist. 


private 


type LIST_INSTANCE; 
type LIST is access LIST_INSTANCE; 


end GENERIC_LIST; 


with UNCHECKED DEALLOCATION; 
package body GENERIC _LIST is 


type NODE; 
type NODE POINTER 1s access NODE; 
type NODE is 


record 
ELEMENT : ITEM TYPE; 
NEXT : NODE_POINTER; 


end record; 
type LIST_INSTANCE is 


record 
HEAD : NODE POINTER := null; 
TAIL > NODE POINTER := null; 
CURRENT : NODE POINTER := null; 
SiZE > natural := 0; 


end record; 


procedure FREE_NODE is new UNCHECKED DEALLOCATION(NODE, NODE POINTER); 
procedure FREE LIST is new UNCHECKED DEALLOCATION(LIST_INSTANCE, LIST); 


procedure FIND FIRST(L : in out LIST) is 
-- pre - The 11st L iS not empty. 
-- post - The first node is the current node. 
-- exceptions raised - LIST _UNDERFLOW if L is empty. 
begin 

if (EMPTY(L)) then 

raise LIST _UNDERFLOW; 

end if; 

L.CURRENT := L.HEAD; 
end FIND FIRST; 
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procedure FIND NEXT(L : in out LIST) 1s 
-- pre - The list L is not empty and the last node is not the current node. 
-- post - c-next in L is the current node. 
-- exceptions raised - LIST_UNDERFLOW if L is empty. 
= - LIST_OVERFLOW if the last node is the current node. 
begin 
if (EMPTY(L)) then 
raise LIST_UNDERFLOW; 
end if; 
if (LAST(L)) then 
raise LIST_OVERFLOW; 
end if; 
L.CURRENT := L.CURRENT.NEXT; 
end FIND_NEXT; 


procedure FIND PREVIOUS(L : in out LIST) is 
-- pre - The list L is not empty and the first node is not the current node. 
-- post - c-prior in L is the current node. 
-- exceptions raised - LIST _UNDERFLOW if L is empty or c is the first node. 
TEMP POINTER : NODE POINTER; 
begin 
if (EMPTY(L) or FIRST(L)) then 
raise LIST _UNDERFLOW; 
end if; 
TEMP_POINTER := L.HEAD; 
while (TEMP _POINTER.NEXT /= L.CURRENT) loop 
TEMP_POINTER := TEMP_POINTER.NEXT; 
end loop; 
L.CURRENT := TEMP_POINTER; 
end FIND PREVIOUS; 


procedure FIND _LAST(L : in out LIST) is 
-- pre - The list L is not empty. 
-- post - The last node in L is the current node. 
-- exceptions raised - LIST_UNDERFLOW if L is empty. 
begin 
if (EMPTY(L)) then 
raise LIST _UNDERFLOW; 
end if; 
while (not LAST(L)) loop 
FIND NEXT(L); 
end loop; 
end FIND LAST; 


procedure RETRIEVE(L : in LIST; ITEM : out ITEM_TYPE) is 
-- pre - The list L is not empty. 
-- post - ITEM contains the value of the element in the current node. 
-- exceptions raised - LIST_UNDERFLOW if L is empty. 
begin 
if (EMPTY(L)) then 
raise LIST UNDERFLOW; 
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end if; 
ITEM := L.CURRENT.ELEMENT; 
end RETRIEVE; 


procedure UPDATE(L : in out LIST; ITEM : in ITEM_TYPE) is 
-- pre - The list L is not empty. 
-- post - The current node in L contains ITEM as its element. 
-- exceptions raised - LIST_UNDERFLOW if L is empty. 
begin 

if (EMPTY(L)) then 

raise LIST_UNDERFLOW; 

end if; 

L.CURRENT.ELEMENT := ITEM; 
end UPDATE; 


procedure INSERT(L : in out LIST; ITEM : in ITEM_TYPE) is 
-- pre - The number of nodes in L has not reached its bound. 
-- post - A node containing ITEM is the last node in the list, and the last 
= node in L-pre, if any, is its predecessor. The node containing 
== ITEM is the current node. 
-- exceptions raised - LIST_OVERFLOW if L has reached its bound. 
TEMP POINTER : NODE_POINTER; 
begin 
if (FULL(L)) then 
raise LIST OVERFLOW; 
end if; 
TEMP_POINTER := new NODE’(ITEM, null); 
if (L.HEAD = null) then 
L.HEAD := TEMP_POINTER; 
L.TAIL := TEMP_POINTER; 


else 
L.TAIL.NEXT := TEMP_POINTER; 
L.TAIL = TEMP_POINTER; 
end if; 


L.CURRENT := TEMP POINTER; 
LwSEZE 32> L.SIZE + 1; 
end INSERT; 


procedure DELETE(L : in out LIST) is 
-- pre - The list L is not empty. 
-- post - c-pre in not in the list L. If c-pre was the first node, 
ea then c-next, if it exists, is the successor of c-prior. If the 
-- list L is not empty, then the last node is the current node. 
-- exceptions raised - LIST _UNDERFLOW if L is empty. 
TEMP POINTER : NODE POINTER; 
begin 
if (EMPTY(L)) then 
raise LIST_UNDERFLOW; 
end if; 
1f (t.CURRENT /= L.HEAD) then 
TEMP POINTER := L.HEAD; 
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while (TEMP_POINTER.NEXT /= L.CURRENT) loop 
TEMP POINTER := TEMP_POINTER.NEXT; 
end loop; 
TEMP POINTER.NEXT := L.CURRENT.NEXT; 
if (L.CURRENT = L.TAIL) then 
L.TAIL := TEMP POINTER; 
end 1f; 
else 
if (L.HEAD = L.TAIL) then 
L.TAIL := null; 
end if; 
L.HEAD := L.HEAD.NEXT; 
end if; 
FREE NODE(L.CURRENT); 
L.CURRENT := L.TAIL; 
ole: = L.SIZE - 1; 
end DELETE; 


function SIZE OF(L : in LIST) return natural is 
-- post - SIZE_OF is the number of nodes in list L. 
begin 
return (L.SIZE); 
end SIZE_OF; 


function EMPTY(L : in LIST) return boolean is 
-- post - If the list L has no nodes then EMPTY is true, else EMPTY is 
= false. 
begin 
return (L.HEAD = null); 
end EMPTY; 


function FULL(L : in LIST) return boolean is 
-- post - If the number of nodes in the list L has reached the maximum 
=- allowed, then FULL is true, else FULL is false. 
TEMP_POINTER : NODE_POINTER; 
begin 
TEMP_POINTER := new NODE; 
FREE _NODE( TEMP_POINTER); 
return (FALSE); 
exception 
when STORAGE_ERROR => 
return (TRUE); 
when others => 
raise; 
end FULL; 


function FIRST(L : in LIST) return boolean is 

-- pre - The list L 1s not empty. 

-~ post - If the first node is the current node in L then FIRST 15 true, else 
ad FIRST is false. 

-- exceptions raised - LIST_UNDERFLOW if L 1s empty. 
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begin 
if (EMPTY(L)) then 
raise LIST_UNDERFLOw; 
end if; 
return (L.CURRENT = L.HEAD); 
end FIRST; 


function LAST(L : in LIST) return boolean is 
-- pre - The list L is not empty. 
-- post - If the last node is the current node in L then LAST is true, else 
= LAST is false. 
-- exceptions raised - LIST_UNDERFLOW if L is empty. 
begin 

if (EMPTY(L)) then 

raise LIST _UNDERFLOW; 

end if; 

return (L.CURRENT = L.TAIL); 
end LAST; 


procedure CREATE(L : in out LIST; SUCCESS : out boolean) is 
-- post - If a vist L can be created then L exists and is empty, and SUCCESS 
-- is TRUE else SUCCESS is FALSE. 
begin 
L := new LIST_INSTANCE'({null], null, null, 0); 
SUCCESS. := TRUE: 
exception 
when STORAGE ERROR => 
SUCCESS <= FALSE; 
when others => 
raise; 
end CREATE; 


procedure DISPOSE(L : 1m out LIST) is 
-- post - L-pre does not exist. 
begin 
if (mot EMPTY(L)) then 
FIND _LAST(L); 
while (not EMPTY(L)) loop 
DELETE(L); 
end loop; 
end if; 
FREE LISI(E): 
end DISPOSE; 


end GENERIC LIST; 
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-- TITLE: ADAF LOW -- 


-- MODULE NAME: PACKAGE ORDERED GENERIC LIST -- 
-- FILE NAME: ORD_LIST.ADA -- 


-- DATE CREATED: 18 APR 88 =o 
-- LAST MODIFIED: 28 APR 88 mo 


-- AUTHOR(S): LT ALBERT J. GRECCO, USN = 


-- DESCRIPTION: This package defines the operations ae 
SS available on the abstract data type LIST. 25 


——FFSFSFSSFSSSS SSS SS SSS SS SHE SSS SSSS SSS SHS SS SSS SSSESSES SS SSHESSSSSSSSE SHEE SsB_. 


generic 
type ITEM TYPE is private; 
package ORDERED GENERIC LIST is 


type LIST is limited private; 


LIST_OVERFLOW : exception; 
LIST _UNDERFLOW : exception; 


-- Operations: If the list is not empty, then one of the nodes is designated 
lad as the current node. Ocaasionally, in the postcondition, it is necessary 
= to refer to the list of the current node as they were immediately before 
as execution of the operation. L-pre and c-pre, respectively, are employed 
om for these references. 


procedure FIND FIRST(L : in out LIST); 

= pre - The list L is not empty. 

-- post - The first node is the current node. 

-- exceptions raised - LIST_UNDERFLOW if L is empty. 


procedure FIND_NEXT(L : in out LIST); 

-- pre - The list L is not empty and the last node is not the current node. 
-- post - c-next in L is the current node. 

-- exceptions raised - LIST_UNDERFLOW if L is empty. 

i - LIST_OVERFLOW if the last node is the current node. 


procedure FIND PREVIOUS(L : in out LIST); 

-- pre - The list L is not empty and the first node is not the current node. 
~- post - c-prior in L is the current node. 

-- exceptions raised - LIST _UNDERFLOW if L is empty or c is the first node. 


procedure FIND_LAST(L : in out LIST); 
-- pre - The list L is not empty. 
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-- post - The last node in L is the current node. 
-- exceptions raised - LIST_UNDERFLOW if L is empty. 


precedure RETRIEVE(E : im LEST; [TEM = out TNEMSIYPE): 

-- pre - The list L is not empty. 

-- post - ITEM contains the value of the element in the current node. 
-- exceptions raised - LIST_UNDERFLOW if L is empty. 


procedure UPDATE(L : in out LIST; ITEM : in ITEM TYPE); 

-- pre - The list L is not empty. 

-- post - The current node in L contains ITEM as its element. 
~~ exceptions raised - LIST_UNDERFLOW if L is empty. 


procedure INSERT(L : in out LIST; ITEM : in ITEM_TYPE; KEY : in positive); 
-- pre - The number of nodes in L has not reached its bound. 

-- post - A node containing ITEM is in the list in ascending order 

ie specified by KEY. The node containing ITEM is the current node. 
-- exceptions raised - LIST OVERFLOW if L has reached its bound. 


procedure DELETE(L : in out LIST); 

-- pre - The list L is not empty. 

-- post - c-pre in not in the list L. If c-pre was the first node, 

a then c-next, if it exists, is the successor of c-prior. If the 
a list L is not empty, then the last node is the current node. 

-- exceptions raised - LIST_UNDERFLOW if L is empty. 


function SIZE_OF(L : im LIST) return natural; 
-- post - SIZE _OF is the number of nodes in list L. 


function EMPTY(L : in LIST) return boolean; 
-- post - If the list L has no nodes then EMPTY 1s true, else EMPTY is 
ae false. 


function FULL(L : in LIST) return boolean; 
-- post - If the number of nodes in the list L has reached the maximum 
= allowed, then FULL is true, else FULL is false. 


function FIRST(L : in LIST) return boolean; 

-- pre - The list L iS not empty. 

-- post - If the first node is the current node in L then FIRST is true, else 
-- FIRST is false. 

-- exceptions raised - LIST_UNDERFLOW if L 1s empty. 


function LAST(L : in LIST) return boolean; 

-- pre - The list L is not empty. 

-- post - If the last node is the current node in L then LAST is true, else 
aS LAST is false. 

-- exceptions raised - LIST _UNDERFLOW if L is empty. 
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procedure CREATE({L : in out LIST; SUCCESS : out boolean); 
-- post - If a list L can be created then L exists and is empty, and SUCCESS 
-- is TRUE else SUCCESS 1s FALSE. 


procedure DISPOSE(L : in out LIST); 
-- post - L-pre does not exist. 


private 


type LIST_INSTANCE; 
type LIST is access LIST_INSTANCE; 


end ORDERED _GENERIC_LIST; 


with UNCHECKED _DEALLOCATION; 
package body ORDERED GENERIC_LIST is 


type NODE; 
type NODE POINTER 1s access NODE; 
type NODE is 


record 
KEY : positive; 
ELEMENT : ITEM_TYPE; 
NEXT : NODE_POINTER; 


end record; 
type LIST_INSTANCE is 


record 
HEAD : NODE POINTER := null; 
TAIL : NODE_POINTER := null; 
CURRENT : NODE POINTER := null; 
S1ZE : natural := 0; 


end record; 


procedure FREE NODE is new UNCHECKED DEALLOCATION(NODE, NODE_POINTER); 
procedure FREE_LIST is new UNCHECKED DEALLOCATION(LIST_INSTANCE, LIST); 


procedure FIND FIRST(L : in out LIST) 158 
-~ pre - The list L is not empty. 
-- post - The first node is the current node. 
-- exceptions raised - LIST_UNDERFLOW if L is empty. 
begin 

if (EMPTY(L)) then 

raise LIST_UNDERFLOW; 

end if; 

L.CURRENT := L.HEAD; 
end FIND FIRST; 


procedure FIND NEXT(L : in out LIST) 18 

-- pre - The list L 1S not empty and the last node is not the current node. 
-- post - c-next in L 1s the Current node. 

-- exceptions raised - LIST UNDERFLOW if L 1s empty. 
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= - LIST_OVERFLOW if the last node is the current node. 
begin 
if (EMPTY(L)) then 
raise LIST_UNDERFLOW; 
end if; 
if (LAST(L)) then 
raise LIST_OVERFLOwW; 
end if; 
L.CURRENT := L.CURRENT.NEXT; 
end FIND_NEXT; 


procedure FIND PREVIOUS(L : in out LIST) is 
-- pre - The list L is not empty and the first node is not the current node. 
-- post - c-prior in L is the current node. 
-- exceptions raised - LIST_UNDERFLOW if L is empty or c is the first node. 
TEMP POINTER :; NODE_POINTER; 
begin 
if (EMPTY(L) or FIRST(L)) then 
raise LIST _UNDERFLOW; 
end if; 
TEMP_POINTER := L.HEAD; 
while (TEMP_POINTER.NEXT /= L.CURRENT) loop 
TEMP_POINTER := TEMP_POINTER.NEXT; 
end loop; 
L.CURRENT := TEMP_POINTER; 
end FIND PREVIOUS; 


procedure FIND LAST(L : in out LIST) is 
-- pre - The list L is not empty. 
-- post - The last node in L is the current node. 
-- exceptions raised - LIST_UNDERFLOW if L is empty. 
begin 
if (EMPTY(L)) then 
raise LIST_UNDERFLOW; 
end if; 
while (not LAST(L)) loop 
FIND _NEXT(L); 
end loop; 
end FIND LAST; 


procedure RETRIEVE(L : in LIST; ITEM : out ITEM_TYPE) is 
"= pre = thelist Eas not emply: 
-- post - ITEM contains the value of the element in the current node. 
-- exceptions raised - LIST_UNDERFLOW if L is empty. 
begin 

if (EMPTY(L)) then 

raise LIST _UNDERFLOW; 

end if; 

ITEM := L.CURRENT.ELEMENT ; 
end RETRIEVE; 
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procedure UPDATE{L : in out LIST; ITEM : im ITEM_TYPE) is 
meaepree - the list L 1s not empty. 
-- post - The current node in L contains ITEM as its element. 
-- exceptions raised - LIST _UNDERFLOW if L 1s empty. 
begin 

if (EMPTY(L)) then 

raise LIST _UNDERFLOW; 

end if; 

L.CURRENT.ELEMENT := ITEM; 
end UPDATE; 


procedure INSERT(L : in out LIST; ITEM : in ITEM_TYPE; KEY : in positive) 15s 


-- pre - The number of nodes in L has not reached its bound. 
-- post - A node containing ITEM is in the list 1n ascending order 
ac specified by KEY. The node containing [TEM 1s the current node. 
-- exceptions raised - LIST OVERFLOW if L has reached its bound. 
TEMP_POINTER : NODE POINTER; 
SEARCH_POINTER : NODE_POINTER; 
begin 
if (FULL(L)) then 
raise LIST_OVERFLOW; 
end if; 
TEMP POINTER := new NODE'( KEY, ITEM, null); 
if (L.HEAD = null) then 
L.HEAD := TEMP_POINTER; 
EetATL := TEMP POINTER; 
else 
if (L.HEAD.KEY > KEY) then 
TEMP_POINTER.NEXT := L.HEAD; 
L.HEAD := TEMP POINTER; 
else 
SEARCH_POINTER := L.HEAD.NEXT; 
if (SEARCH POINTER /= null) then 
if (SEARCH_POINTER.KEY > KEY) then 
TEMP POINTER.NEXT := SEARCH POINTER; 
L.HEAD.NEXT := TEMP_POINTER; 
else 
while ((SEARCH POINTER.NEXT /= null) and then 
(SEARCH _POINTER.NEXT.KEY < KEY)) loop 
SEARCH POINTER := SEARCH POINTER.NEXT; 
end loop; 
TEMP_POINTER.NEXT := SEARCH_POINTER.NEXT; 
SEARCH _POINTER.NEXT := TEMP POINTER; 
if (SEARCH_POINTER = L.TAIL) then 
L.TAIL := TEMP_POINTER; 
end if; 
end if; 
else 
L.HEAD.NEXT := TEMP_POINTER; 
tals TEMP POINTER: 
end if; 
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end if; 
end if; 
L.CURRENT := TEMP POINTER; 
LE, SIZE 4. = tees 2 Eee. 
end INSERT; 


procedure DELETE(L : 1m out LIST) is 
-- pre - The list L 1s not empty. 
-- post - c-pre in not in the list L. If c-pre was the first node, 
Se then c-next, if it exists, is the successor of c-prior. If the 
2c list L is not empty, then the last node is the current node. 
-- exceptions raised - LIST_UNDERFLOW if L is empty. 
TEMP POINTER : NODE POINTER; 
begin 
if (EMPTY(L)) then 
raise LIST_UNDERFLOW; 
end if; 
if (L.CURRENT /= L.HEAD) then 
TEMP POINTER := L.HEAD; 
while (TEMP _POINTER.NEXT /= L.CURRENT) loop 
TEMP POINTER := TEMP_POINTER.NEXT; 
end loop; 
TEMP_POINTER.NEXT := L.CURRENT.NEXT; 
if (L.CURRENT = L.TAIL) then 
L.TAIL := TEMP POINTER; 
end if; 
else 
if (L.HEAD = L.TAIL) then 
L.TAIL := null; 
end if; 
L.HEAD := L.HEAD.NEXT; 
end if; 
FREE NODE(L.CURRENT); 
L.CURRENT := L.TAIL; 
LE. SLZe = (Lb SIZE = 4s 
end DELETE; 


function SIZE OF(L : in LIST) return natural its 
-- post - SIZE_OF is the number of nodes in list L. 
begin 
return (LOSTZE); 
end SIZE OF; 


function EMPTY(L : in LIST) return boolean is 
-- post - If the list lL has no nodes then EMPTY is true, else EMPTY is 
a false. 
begin 
return (L.HEAD = null); 
end EMPTY; 
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function FULL(L : in LIST) return boolean is 
-- post - If the number of nodes in the list L has reached the maximum 
== allowed, then FULL is true, else FULL is false. 
TEMP POINTER : NODE POINTER; 
begin 
TEMP POINTER := new NODE; 
FREE _NODE( TEMP_POINTER); 
return (FALSE); 
exception 
when STORAGE ERROR => 
return (TRUE); 
when others => 
raise; 
end FULL; 


function FIRST(L : in LIST) return boolean is 
-- pre - The list L is not empty. 
-- post - If the first node is the current node in L then FIRST is true, else 
== FIRST is false. 
-- exceptions raised - LIST_UNDERFLOW if L is empty. 
begin 

if (EMPTY(L)) then 

raise LIST_UNDERFLOW; 

end if; 

return (L.CURRENT = L.HEAD); 
end FIRST; 


function LAST(L : in LIST) return boolean is 
-- pre - The list L 1S not empty. 
-- post - If the last node is the current node in L then LAST is true, else 
a LAST is false. 
-- exceptions raised - LIST_UNDERFLOW if L is empty. 
begin 

if (EMPTY(L)) then 

raise LIST_UNDERFLOw; 

end if; 

return (L.CURRENT = L.TAIL); 
end LAST; 


procedure CREATE(L : in out LIST; SUCCESS : out boolean) is 
-- post - If a list L can be created then L exists and is empty, and SUCCESS 
-- is TRUE else SUCCESS is FALSE. 
begin 
L := new LIST_INSTANCE'(nul], null, null, 0); 
SUECESS := TRUE: 
exception 
when STORAGE_ERROR => 
SUCCESS := FALSE: 
when others => 
raise; 
end CREATE; 
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procedure DISPOSE(L : in out LIST) is 
== post — L-prey does not exist. 
begin 
if (not EMPTY(L)) then 
FIND_LAST(L); 
while (not EMPTY(L)) loop 
DELETE(L); 
end loop; 
end if; 
FREE_LIST(L); 
end DISPOSE; 


end ORDERED GENERIC LIST; 
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-- TITLE: ADAFLOW -- 
-- MODULE NAME: = PACKAGE GENERIC_STACK -- 
-- FILE NAME: STACK .ADA -- 


-- DATE CREATED: 31 MAR 88 a 
-- LAST MODIFIED: 28 APR 88 ws 


-- AUTHOR(S): LT ALBERT J. GRECCO, USN -- 


-- DESCRIPTION: This package defines the operations a 
oS available on the abstract data type STACK. ii 


——_ SF SSPSSSSSSSS SHAS SS SSSSASSHSSSTASSSSSAAST ASSESS SSSSFHSSSsSs ss sss sssaaszsaa__ 


generic 
type ITEM_TYPE is private; 
package GENERIC STACK is 


type STACK is limited private; 


STACK_OVERFLOW : exception; 
STACK_UNDERFLOW : exception; 


procedure POP(S : 1n out STACK; ITEM : out ITEM TYPE); 

-- pre - The stack S is not empty. 

-- post - ITEM contains the most recently arrived element of S-pre. 
- S no longer contains ITEM. 

-- exceptions raised - STACK_UNDERFLOW if S is empty. 


procedure TOP(S : in STACK; ITEM : out ITEM TYPE); 

-- pre - The stack S is not empty. 

-- post - ITEM contains the most recently arrived element of S-pre. 
-- exceptions raised - STACK_UNDERFLOW if S is empty. 


procedure PUSH(S : in out STACK; ITEM : in ITEM_TYPE); 

-- pre - The size of S has not reached its bound. 

-- post - S includes ITEM as its most recently arrived element. 
-- exceptions raised - STACK_OVERFLOW if S has reached its bound. 


function EMPTY(S : in STACK) return boolean; 
-- post - If the stack S has no ITEMS then EMPTY is true, else EMPTY 1s 
=< false. 


function FULL(S : in STACK) return boolean; 


-- post - If the number of ITEMS in the stack S has reached the maximum 
-- allowed, then FULL 1s true, else FULL is false. 
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procedure CREATE(S : in out STACK; SUCCESS : out boolean); 
-- post - If a stack S can be created then S exists and is empty, and SUCCESS 
-- is TRUE else SUCCESS is FALSE. 


procedure DISPOSE(S : in out STACK); 
-- post - S-pre does not exist. 


private 


type NODE; 
type STACK is access NODE; 


end GENERIC_STACK; 


with UNCHECKED DEALLOCATION; 
package body GENERIC _STACK is 


type NODE is 


record 
EEEMENT << ITEM TYPE; 
NEXT : STACK; 


end record; 
procedure FREE NODE is new UNCHECKED DEALLOCATION(NODE, STACK); 


procedure POP(S : in out STACK; ITEM : out ITEM TYPE) is 
-- pre - The stack S is not empty. 
-- post - ITEM contains the most recently arrived element of S-pre. 
aa S no longer contains ITEM. 
-- exceptions raised - STACK_UNDERFLOW if S is empty. 
TEMP POINTER : STACK; 
begin 

if (EMPTY(S)) then 

raise STACK_UNDERFLOW; 

end if; 

ITEM := S.ELEMENT; 

TEMP_POINTER := S; 

Sy SS SUES 

FREE _NODE( TEMP_POINTER); 
end POP; 


procedure TOP(S : in STACK: ITEM : owt ITEM _[YPE) 1s 
-- pre - The stack S is not empty. 
-- post - ITEM contains the most recently arrived element of S-pre. 
-- exceptions raised - STACK_UNDERFLOW if S is empty. 
begin 

if (EMPTY(S)) then 

raise STACK _UNDERFLOW; 

end if; 

ITEM := S.ELEMENT; 
end JOP; 
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procedure PUSH(S : in out STACK; ITEM : in ITEM_TYPE) is 
-- pre - The size of S has not reached its bound. 
-- post - S includes ITEM as its most recently arrived element. 
-- exceptions raised - STACK_OVERFLOW if S has reached its bound. 
TEMP POINTER : STACK; 
begin 

if (FULL(S)) then 

raise STACK_OVERFLOW; 

end if; 

TEMP POINTER := new NODE'(ITEM, S); 

S := TEMP_POINTER; 
end PUSH; 


function EMPTY(S : in STACK) return boolean is 
-- post - If the stack S has no ITEMS then EMPTY is true, else EMPTY is 


== false. 
begin 

return (S = null); 
end EMPTY; 


function FULL(S : in STACK) return boolean is 
-- post - If the number of ITEMS in the stack S has reached the maximum 
a3 allowed, then FULL is true, else FULL is false. 
TEMP POINTER : STACK; 
begin 
TEMP_POINTER := new NODE; 
FREE _NODE( TEMP_POINTER); 
return (FALSE); 
exception 
when STORAGE ERROR => 
return (TRUE); 
when others => 
raise; 
end FULL; 


procedure CREATE(S : in out STACK; SUCCESS : out boolean) is 
-- post - If a stack S can be created then S exists and is empty, and SUCCESS 
oe is TRUE else SUCCESS is FALSE. 
begin 
S := null; 
SUECESS := TRUE; 
end CREATE; 


procedure OISPOSE(S : in out STACK) is 
-~- post - S-pre does not exist. 
TEMP_POINTER : STACK; 
begin 
while (S /= null) loop 
TEMP_POINTER := S; 
S §2 Soller s 
FREE _NODE( TEMP POINTER); 
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end loop; 
end DISPOSE; 


end GENERIC_STACK; 
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